#!/usr/local/bin/perl # enter_received_anq_into_isql_database.pl - CGI script using IBPerl 0.7 # # This script automatically enters quality-of-life-data from a received # *.anq file into an isql database via IBPerl. # # It uses the target database /databases/anq.gdb. # If this is not available, it creates it. # # This script opens an anq-file, # extracts patient id information, # extracts all session data information and # stores this in /databases/anq.gdb. # # results from each questionnaire are stored in one table. # if this table doesn't exist yet, it is automatically created. # # patient id data are linked to /databases/patienten.pl via patnr. # this means, that patients identification data are kept in patienten.pl; # when processing a new *.anq, patienten.pl is first scanned for a matching # patient. if none is available, an entry in patienten.pl is generated # automatically. # # Currently, this is a pure import_to_database_script. It does not have # any html functionality yet. # # This script was started at 1999-11-24, based on patientenauswahl.pl. # # Copyright 1999 Joerg Sigle # # Cave: Nicht alle Zugriffsvariablen sind lokal, nicht alle dürfen es # aus unbekannten Gründen bei DB-Zugriffen sein - siehe sub suchen. js2609990015 # Dies bitte bei irgendwann geplantem Umbau für fast-CGI beachten und testen! # Dieses Script ist zugunsten der Verständlichkeit ausführlich kommentiert. # Beim Performance-Tuning kann stattdessen auf dem Server eine Version installiert werden, bei der alle # Kommentarzeilen entfernt sind, oder es kann vorcompiliertes Perl verwendet werden (empfohlen). use IBPerl; $version='0.02'; print "\n"; print "-----------------------------------------------------------------------------\n"; print "AnyQuest for Windows data file to Interbase data transfer script Version $version\n"; print "-----------------------------------------------------------------------------\n"; print "\n"; (&usage && die "No file to process supplied.\n\n") unless @ARGV; #------------------------------------------------------------------------------------------------------------ # Globale Variablen, pro handling contra performance nur einmal hier vorne #------------------------------------------------------------------------------------------------------------ $server='my_server_name_or_ip_address'; $databases='/databases/anq.gdb'; $user='my_username'; $password='my_password'; print "Using database $databases on server $server\n"; print "Connecting as $user with password $password\n"; print "\n"; #------------------------------------------------------------------------------------------------------------ # #------------------------------------------------------------------------------------------------------------ $tabelle=''; $suchattribut=''; $suchwert=''; $anqdatasetnr=0; $anqname=''; $anqfirstname=''; $anqlastname=''; $anqgrouppid=''; $anqdob=''; $anqdateoftest=''; $anqstarttime=''; $anqendtime=''; $anqdeltatime=''; $patnr=1; #------------------------------------------------------------------------------------------------------------ # anq-Datei zum lesen öffnen #------------------------------------------------------------------------------------------------------------ $filename=@ARGV[0]; print "Opening file $filename\n"; print "\n"; open(infile,"<$filename") or die "Can't open $filename"; $qnrshortname=''; $qnrlongname=''; $currentsection=''; $parameters_of_this_section=''; while () #as long as input file is not finished { $a=$_; #read next line from input file into $a while (($a ne '') && (substr($a,1,1) eq ' ')) #führende leerzeichen entfernen {substr($a,1,1)=''}; while (($a ne '') && (substr($a,-1,1) le ' ')) #trailende leerzeichen+darunter entfernen {substr($a,-1,1)=''}; if ($a ne '') { if ((index($a,"[")==0) #wenn erstes zn von links [ ist && (rindex($a,"]")==length($a)-1)) #und letztes zn rechts ] ist { if (index($a,"[AnyQuest license]")>=0) {$currentsection="aqlicense"} elsif (index($a,"[patient identification]")>=0) {$currentsection="patid"} elsif (index($a,"[time stamp]")>=0) {$currentsection="timestamp"} elsif (index($a," = ")>0) #und = enthalten ist { #dann ist das wohl eine questionnaire block start headline local $i=index($a," = "); #also bitte kurzen und langen dateinamen herausziehen $qnrshortname=substr($a,1,$i-1); $qnrlongname=substr($a,$i+3,length($a)-$i-4); $currentsection="qnrname"; } else { #für alle anderen section headers: if (($currentsection ne '') #wenn zuletzt eine ernsthafte section durchgegangen wurde, && ($currentsection ne "aqlicense") && ($currentsection ne "patid") && ($currentsection ne "timestamp") && ($currentsection ne "qnrname")) { #dann daraus generierte tabelle jetzt in die isql-datenbank eintragen. if ($parameters_of_this_section ne '') {$parameters_of_this_section=",$parameters_of_this_section"}; # falls noch nicht vorhanden: erst mal eine datasetnr gewinnen, und dazu auch # die infos zum patienten in die tabelle measurement_information eintragen: if ($anqdatasetnr==0) { print "Hole neue ANQ DataSetNr. ... "; # Tabelle anlegen, falls sie nicht schon existiert $query="CREATE TABLE measurement_information (anqdatasetnr int,". "anqname varchar(100),". "anqfirstname varchar(100),". "anqlastname varchar(100),". "anqdob varchar(10),". "anqgrouppid varchar(100),". "patnr int,". "anqdateoftest varchar(10),". "anqstarttime varchar(8),". "anqendtime varchar(8),". "anqdeltatime varchar(8),". "qnrshortname varchar(100),". "qnrlongname varchar(100));"; #print "$query\n"; # genaue datentypen wären teils eigentlich date oder time, aber das versteht # sql dialekt 1 der interbase so nicht # und ich habe jetzt keine lust darauf, # den dialekt zu wechseln oder # timestamp passend auszufieseln. &QueryInterBase; # nächste neue anqdatasetnr geben lassen $anqdatasetnr=&neue_anqdatasetnr; print "Dies ist ANQ DataSetNr. $anqdatasetnr\n"; print "Patientendaten aus ANQ-Datei: $anqname $anqfirstname $anqlastname, $anqdob, $anqgrouppid\n"; $patnr=$anqgrouppid; print "Zugeordnet im KIS der Patientennummer: $patnr\n"; print "Befragungsdatum: $anqdateoftest, $anqstarttime\n"; print "\n"; } # jeden einzelnen Datensatzschrieb in eine ANQ-Daten-Tabelle protokollieren! $query="INSERT INTO measurement_information VALUES ($anqdatasetnr,'" .$anqname."','" .$anqfirstname."','" .$anqlastname."','" .$anqdob."','" .$anqgrouppid."'," .$patnr.",'" .$anqdateoftest."','" .$anqstarttime."','" .$anqendtime."','" .$anqdeltatime."','" .$qnrshortname."','" .$qnrlongname."');"; #print "$query\n"; &QueryInterBase; print "Schreibe Ergebnisse für...\n"; print "ANQ DataSetNr. $anqdatasetnr\n"; print "Fragebogen $qnrshortname, $qnrlongname\n"; print "Table $currentsection\n"; $query="CREATE TABLE $currentsection (anqdatasetnr int$parameters_of_this_section);"; &QueryInterBase; if ($values_of_this_section ne '') {$values_of_this_section=",$values_of_this_section"}; $query="INSERT INTO $currentsection VALUES ('$anqdatasetnr'$values_of_this_section);"; &QueryInterBase; $parameters_of_this_section=''; $values_of_this_section=''; print "\n"; $currentsection=substr($a,0,33); substr($currentsection,0,1)=''; #remove leading [ substr($currentsection,-1,1)=''; #remove trailing ] while (index($currentsection," ")>0) #im tabellennamen leerzeichen durch _ ersetzen {substr($currentsection,index($currentsection," "),1)="_"}; while (index($currentsection,".")>0) #im tabellennamen punkte durch _ ersetzen {substr($currentsection,index($currentsection,"."),1)="_"}; while (index($currentsection,"/")>0) #im tabellennamen punkte durch _ ersetzen {substr($currentsection,index($currentsection,"/"),1)="_"}; } else { $currentsection=substr($a,0,33); substr($currentsection,0,1)=''; #remove leading [ substr($currentsection,-1,1)=''; #remove trailing ] while (index($currentsection," ")>0) #im tabellennamen leerzeichen durch _ ersetzen {substr($currentsection,index($currentsection," "),1)="_"}; while (index($currentsection,".")>0) #im tabellennamen punkte durch _ ersetzen {substr($currentsection,index($currentsection,"."),1)="_"}; while (index($currentsection,"/")>0) #im tabellennamen punkte durch _ ersetzen {substr($currentsection,index($currentsection,"/"),1)="_"}; } } } else { #für normale zeilen zwischen den sections: if ($currentsection eq "timestamp") #wenn gerade die patient id erfaßt wird { #wenn möglich: namen, geburtsdatum und patientid des patienten finden ($label,$value)=split(/:/,$a,2); #aktuelle zeile in $label und $value splitten $value=~s/^\ *//m; #führende leerzeichen aus $value entfernen if ($label eq 'date of test') {$anqdateoftest=$value}; if ($label eq 'start time') {$anqstarttime=$value}; if ($label eq 'end time') {$anqendtime=$value}; if ($label eq 'delta time') {$anqdeltatime=substr($value,0,8)}; } if ($currentsection eq "patid") #wenn gerade die patient id erfaßt wird { #wenn möglich: namen, geburtsdatum und patientid des patienten finden ($label,$value)=split(/:/,$a,2); #aktuelle zeile in $label und $value splitten $value=~s/^\ *//m; #führende leerzeichen aus $value entfernen if ($label eq 'group/pid') {$anqgrouppid=$value}; if ($label eq 'name') {$anqname=$value}; if ($label eq 'firstname') {$anqfirstname=$value}; if ($label eq 'lastname') {$anqlastname=$value}; if ($label eq 'date of birth') {$anqdob=$value}; } if (($currentsection ne '') #wenn gerade eine questionnaire-daten enthaltente section gelesen wird, && ($currentsection ne "aqlicense") && ($currentsection ne "patid") && ($currentsection ne "timestamp") && ($currentsection ne "qnrname")) { #dann zeile in $parameters... und $values... aufnehmen. local $i=index($a,":"); if ($i>30) #länge des parameternamens beschränken { substr($a,30,$i-30)=""; $i=index($a,":"); }; while ((index($a," ")>0) && (index($a," ")<$i)) #im parameternamen leerzeichen durch _ ersetzen {substr($a,index($a," "),1)="_"}; while ((index($a,".")>0) && (index($a,".")<$i)) #im parameternamen punkte durch _ ersetzen {substr($a,index($a,"."),1)="_"}; while ((index($a,"/")>0) && (index($a,"/")<$i)) #im parameternamen punkte durch _ ersetzen {substr($a,index($a,"/"),1)="_"}; if ($parameters_of_this_section ne '') #komma anhängen, um mehr als 1 parameter zu trennen {$parameters_of_this_section=$parameters_of_this_section.","} $parameters_of_this_section=$parameters_of_this_section.substr($a,0,$i)." varchar(30)"; substr($a,0,$i)=''; #parameternamen und doppelpunkt entfernen while (($a ne '') && (substr($a,0,1)==" ")) #leading " " entfernen {substr($a,0,1)=""} if ($values_of_this_section ne '') #komma anhängen, um mehr als 1 parameter=value zu trennen {$values_of_this_section=$values_of_this_section.","} $values_of_this_section="$values_of_this_section'$a'"; } } } } close infile; print "\n"; exit(0); #------------------------------------------------------------------------------------------------------------ # Funktionen und Prozeduren: # SQL-Statements in Abhängigkeit von Knopfdrücken und angegebenen Variablen generieren # Dieser Teil enthält die Datenbankzugriffs-Logik, die sich bei diesem Formular zunächst auf eine # Query je gedrücktem Knopf beschränke #------------------------------------------------------------------------------------------------------------ sub eintragen { if ($q->param('patnr') eq '') { $query="INSERT INTO $tabelle (patnr,"; foreach $name (@names) { if ((index($name,'button')!=0) && (index($name,'patnr')!=0)) {$query=$query.$name.",";} # alle namen von parametern außer buttons mit nachfolgendem komma anfügen }; if (substr($query,-1,1) eq ",") # nur weiter, wenn überhaupt parameter angegeben wurden { substr($query,-1,1)=") VALUES (".&neue_patnr.","; foreach $name (@names) { if ((index($name,'button')!=0) && (index($name,'patnr')!=0)) {$query=$query.'"'.$q->param($name).'"'.","} # alle werte außer buttons mit nachfolgendem komma anfügen }; substr($query,-1,1)=");"; &QueryInterBase; } } else { $query="UPDATE $tabelle SET "; foreach $name (@names) { if ((index($name,'button')!=0) && (index($name,'patnr')!=0)) {$query=$query.$name."='".$q->param($name)."',"} # alle namen von parametern außer buttons mit nachfolgendem komma anfügen }; if (substr($query,-1,1) eq ",") # nur weiter, wenn überhaupt parameter angegeben wurden { substr($query,-1,1)=" WHERE patnr='".$q->param('patnr')."';"; &QueryInterBase; } } } #------------------------------------------------------------------------------------------------------------ # sucht den angegebenen patienten wie folgt: # wenn eine patientennummer angegeben wurde, wird der datensatz mit der zugehörigen nummer gesucht # Falls nichts gefunden wird, bleiben die anderen Felder unverändert (was schlecht ist). #------------------------------------------------------------------------------------------------------------ sub suchen { # my($st,$tr,$tmt,$db,%row); # my($tr,$tmt,$db,%row); # CAVE! $st darf zumindest HIER nicht "my" und auch nicht "local"!!! sein, # sonst bleibt das Programm am Ende des Blocks, in dem sie definiert wurden, hängen!} # js2509992340 nach langer an mehreren tagen bei gelegenheit mich-fragerei, # und heute wieder langem (seit ) Fehlerisolieren. # Warum das so ist, weiß ich leider nicht. # # Ich finde aber gerade, daß auch aus den übrigen variablen als my nochmals # manchmal erscheint "document contains no data". Und zwar, wenn ich erst # nach vorname M% suchte, dann aus der Liste eine auswählte. Aber ein bißchen # unsystematisch, vielleicht. Ich habe jetzt keine Lust mehr auf Ärger und # lasse "my" hier ganz weg. Punkt. Ein einzelnes CGI-Skript wird wohl hoffentlich # nicht so viele DB-Abfragen gleichzeitig machen, und wenn man es mit # Fast-CGI verwendet, muß man eben davor alle Variablen eventuell richtig # anpassen. js2609990014 # # Das my war ursprünglich in suchen innerhalb eines IF-THEN blocks, und nach dem # Block blieb alles hängen. Wenn ich das my hochgezogen habe, blieb alles dann # hängen, wenn das suchergebnis nur noch ein ergebnis hatte. $suchattribut=$q->param('button_suchen'); # das zu durchsuchende attribut aufschreiben, wurde via JavaScript als wert von button.suchen übergeben substr($suchattribut,0,8)=""; # aus Button-Beschriftung "Suchen (patnr)" werde Suchattribut "patnr" usw. substr($suchattribut,-1,1)=""; $suchwert=$q->param($suchattribut); # den als suchmaske verwendeten wert aufschreiben if ($suchwert gt '') { &VariableFelderImFormularLeeren; # und das formular ganz leeren, damit auch bei teilgefülltem formular eine erfolglose suche auffällt. # bitte nicht (!) mit delete_all leeren, da dann ja leider auch die hidden fields mit dem aktuellen patienten verschwinden! if ((index($suchwert,'%')+index($suchwert,'_'))>-2) {$query="SELECT * FROM $tabelle WHERE $suchattribut LIKE '$suchwert%';"} else {$query="SELECT * FROM $tabelle WHERE $suchattribut = '$suchwert';"}; $db=new IBPerl::Connection(Server=>$server,Path=>$databases,User=>$user,Password=>$password); $tr=new IBPerl::Transaction(Database=>$db); $st=new IBPerl::Statement(Transaction=>$tr,Stmt=>$query); $st->{'Handle'}; $st->open; while (1) { my $ret = $st->fetch(\%row); if ($ret != 0) {last} # wenn rückgabewert <>0 war, dann schleife abbrechen und hinter das ende der schleife springen push (@auswahlliste,[%row]); # ansonsten: den letzten rückgegebenen wert zu einer auswahlliste hinzufügen }; if ($#auswahlliste==0) # falls nur 1 patient gefunden wurde (also die nummer des letzten listenelements=0 ist): seine daten eintragen {for my $k (keys %row) {$q->param(lc($k),&trim($row{$k}))}} else {$q->param($suchattribut,$suchwert)}; # auf jeden Fall den Suchwert wieder eintragen, so daß er bei erfolgloser suche erhalten bleibt $st->close; $tr->commit; $db->disconnect; } } #------------------------------------------------------------------------------------------------------------ # Sollte mich wundern, wenn's das in Perl noch nicht gäbe... # Eine nicht besonders effiziente Funktion, um von einem String führende und trailende Leerzeichen # abzuschneiden. Benötigt, weil SQL Strings jeweils in Feldlänge serviert. #------------------------------------------------------------------------------------------------------------ sub trim { my $a=shift(@_); while ((length($a)>0) && (substr($a,0,1) eq " ")) {substr($a,0,1)=""}; while ((length($a)>0) && (substr($a,-1,1) eq " ")) {substr($a,-1,1)=""}; return $a } #------------------------------------------------------------------------------------------------------------ # generiert die nächste ANQ-Dataset-Nr. # st->fetch(\%row); überträgt eine kombination aus spaltenname und inhalt in eine Zeile des Assoziativen Arrays %row. # spaltenname wird zum key und inhalt wird zum zugehörigen wert. # st->fetch gibt außerdem einen wert zurück, der 0 ist, wenn weitere paare abzuholen sind, 100, wenn listenende war # und deshalb kein wert zurückgegeben wurde, -1 bei anderem fehler. #------------------------------------------------------------------------------------------------------------ sub neue_anqdatasetnr { # my ($tmt,$db,$tr,$st,%row); ausgebaut, s. vorspann 260999js $db=new IBPerl::Connection(Server=>$server,Path=>$databases,User=>$user,Password=>$password); $tr=new IBPerl::Transaction(Database=>$db); $st=new IBPerl::Statement(Transaction=>$tr,Stmt=>'SELECT MAX (anqdatasetnr) FROM measurement_information;'); $st->{'Handle'}; $st->open; $st->fetch(\%row); $st->close; $tr->commit; $db->disconnect; return $row{"MAX"}+1; } #------------------------------------------------------------------------------------------------------------ # generiert die nächste Patientennummer # st->fetch(\%row); überträgt eine kombination aus spaltenname und inhalt in eine Zeile des Assoziativen Arrays %row. # spaltenname wird zum key und inhalt wird zum zugehörigen wert. # st->fetch gibt außerdem einen wert zurück, der 0 ist, wenn weitere paare abzuholen sind, 100, wenn listenende war # und deshalb kein wert zurückgegeben wurde, -1 bei anderem fehler. #------------------------------------------------------------------------------------------------------------ sub neue_patnr { # my ($tmt,$db,$tr,$st,%row); ausgebaut, s. vorspann 260999js $db =new IBPerl::Connection(Server=>$server,Path=>$databases,User=>$user,Password=>$password); $tr =new IBPerl::Transaction(Database=>$db); $st =new IBPerl::Statement(Transaction=>$tr,Stmt=>'SELECT COUNT (*) FROM patienten;'); $st->{'Handle'}; $st->open; $st->fetch(\%row); $st->close; $tr->commit; $db->disconnect; return $row{"COUNT"}+1; } #------------------------------------------------------------------------------------------------------------ # beispiel für ein select-kommando: das ergebnis der selection liegt in @ergebnis. #------------------------------------------------------------------------------------------------------------ sub select_all_pats { # my ($tmt,$db,$tr,$st,%row); ausgebaut, s. vorspann 260999js $db =new IBPerl::Connection(Server=>$server,Path=>$databases,User=>$user,Password=>$password); $tr =new IBPerl::Transaction(Database=>$db); $st =new IBPerl::Statement(Transaction=>$tr,Stmt=>'SELECT * FROM patienten;'); # $st =new IBPerl::Statement(Transaction=>$tr,Stmt=>"SELECT * FROM patienten WHERE patnr = '1';"); $st->{'Handle'}; $st->open; while (1) { my $ret = $st->fetch(\%row); if ($ret == 100) {last}; if ($ret != 0) {last}; print ("
"); for my $k (sort(keys %row)) {print "$k:\t$row{$k}

"} } $st->close; $tr->commit; $db->disconnect; } #------------------------------------------------------------------------------------------------------------ # leitet die aktuelle suchanfrage in $query über IBPerl als eine Transaktion an Interbase 4.0 weiter #------------------------------------------------------------------------------------------------------------ sub QueryInterBase { #my ($tmt,$db,$tr,$st); ausgebaut, s. vorspann 260999js $db =new IBPerl::Connection(Server=>$server,Path=>$databases,User=>$user,Password=>$password); $tr =new IBPerl::Transaction(Database=>$db); $st =new IBPerl::Statement(Transaction=>$tr,Stmt=>$query); if ($st->execute) { $fehler=$st->{Error}; }; $tr->commit; $db->disconnect; } #------------------------------------------------------------------------------------------------------------ # Aktuelle Patientennamen zum aktiven Patienten machen #------------------------------------------------------------------------------------------------------------ sub PatientenAktivieren { # der aktuell ausgewählte patient soll immer z.B. in der kopfzeile jeder # seite dargestellt werden können. deshalb wird er beim drücken des # "Diesen Patienten Auswählen"-Knopfes in entsprechende Variablen übernommen. # Und auch gleich die betroffenen Parameter in den aktuellen # Variablensatz für das Rendern des aktuellen Formulars aufnehmen. $q->param("AktPatVorname", $q->param("vorname") ); $q->param("AktPatNachname",$q->param("nachname")); $q->param("AktPatGebdat", $q->param("gebdat") ); $q->param("AktPatPatnr", $q->param("patnr") ); } #------------------------------------------------------------------------------------------------------------ # Alle Variablen Felder leeren, das ist ein ersatz für # delete_all und für den defaults-button, der die permanenten variablen # (z.B. aktiver Patient) unbeschädigt läßt. #------------------------------------------------------------------------------------------------------------ sub VariableFelderImFormularLeeren { $q->param("vorname",""); $q->param("nachname",""); $q->param("gebdat",""); $q->param("patnr",""); $q->param("sex","unbekannt"); } #------------------------------------------------------------------------------------------------------------ # Alle Variablen Felder leeren, das ist ein ersatz für # delete_all und für den defaults-button, der die permanenten variablen # (z.B. aktiver Patient) unbeschädigt läßt. #------------------------------------------------------------------------------------------------------------ sub usage {print "Dieses Programm trägt die Angegebene *.ANQ-Datei in die Datenbank\n"; print "/databases/anq.gdb ein. PatID/Group wird als Patientennummer verwendet.\n"; print "\n"; }