Quoth (e-mail address removed):
<standard moan>
use strict;
use warnings;
Big box comments like this really don't help readability; and info about
what the module is and does should be put in POD so it can be read later
more easily.
What is this module? It's not on CPAN, so I presume it's yours? By the
looks of things this will need rewriting as well.
Oh right, you've got it down here... use strict and warnings should come
first.
If you say
use open ':encoding(utf8)';
you will get better error handling and fallback facilities when the data
isn't valid.
Don't do this... put it at the end.
You don't need to do this. XML:
OM and XML::LibXML can both parse XML
from a string (though I admit that in the case of XML:
OM the
documentation is less than clear...).
Here is your first problem. CXML objects appear to contain XML:
OM
objects; AFAIK there is no way to transfer a node from an XML::LibXML
tree to an XML:
OM tree short of serialising it and re-parsing. This
means you will have to modify CXML to use XML::LibXML (or whatever) as
well.
Debug messages like this are better sent to stderr with warn.
... or die translate_to_German("couldn't delete auf_temp.anf: $!");
All of this stuff will be the same with XML::LibXML, once you have your
CXML object using the same DOM library.
In theory, as the DOM provides a specification of the methods etc., you
should simply be able to switch 'XML::LibXML' for 'XML:
OM' throughout
and it'll all be fine... it won't, of course (life's never that simple),
but the changes required shouldn't be major.
Ben
Okay, Ben, thank you very much. Here is the complete code for
"CXML.pm" for your interest. Of course, it contains XML:
OM
statements.
Can you have a look at this file as well?
-----------------------------------------------
#!/usr/bin/perl -w
#------------------------------------------------------------------------------#
# CXML.pm
#
#
#
# Modul für die XML-Funktionen des Clients
#
#------------------------------------------------------------------------------#
package CXML;
#------------------------------------------------------------------------------#
# Interne Versionierung
#
#------------------------------------------------------------------------------#
use vars qw/$VERSION $TIMESTAMP/;
# $VERSION = 1.0;
# $TIMESTAMP = 20030321;
# $VERSION = 1.1;
# $TIMESTAMP = 20030627;
# $VERSION = "1.5.4";
# $TIMESTAMP = 20040505;
# $VERSION = "1.5.5.build.1";
# $TIMESTAMP = 20040521;
$VERSION = "1.5.5.build.2";
$TIMESTAMP = 20040604;
#------------------------------------------------------------------------------#
# Laden der internen Module (1)
#
#------------------------------------------------------------------------------#
# XML:
OM ist ein CPAN Modul und existiert in dieser Form nicht auf
# ActiveState, sondern nur unter cpan.perl.org.
# XML:
OM muss daher auf dem Client-Rechner installiert sein!
use XML:
OM;
#------------------------------------------------------------------------------#
# Laden der externen Module (0)
#
#------------------------------------------------------------------------------#
# Pragmata
use diagnostics;
use strict;
use locale;
# use open ':utf8';
return 1;
#------------------------------------------------------------------------------#
# Subroutine zum Anlegen einer neuen "Fallmappe"
#
#------------------------------------------------------------------------------#
sub new {
my $self = {};
$self->{doc} = XML:
OM:
ocument->new();
$self->{xml} = $self->{doc}->createXMLDecl( '1.0', 'UTF-8' );
$self->{root} = undef;
$self->{type} = undef;
$self->{template} = undef;
$self->{arzt} = undef;
bless($self);
return $self;
}
#------------------------------------------------------------------------------#
# Subroutine, um die XML-Struktur aus dem XML-Rootfile und den
referenzierten #
# Dateien zu generieren
#
#------------------------------------------------------------------------------#
sub construct_xml ($) {
my ( $self, $konfiguration ) = @_;
my $rootfile = $konfiguration->get_value('xmlrootfile');
my $gui = $konfiguration->get_value('gui');
my @xmlfiles = $rootfile;
my %xmlroots;
my %xmldocs;
foreach my $current_file (@xmlfiles) {
if ( -r $current_file ) {
if ($gui) { $gui->set_status( 52, $current_file );
$gui->{main}->Busy( -recurse => 1 ); }
else { print CText->get( $konfiguration, 52, $current_file
), "\n"; }
open( XML, $current_file ) or die CText->get(
$konfiguration, 1001, $current_file );
my @file = <XML>;
my $line_tot = @file;
close(XML);
# Für jede XML-Datei einen Datenbaum erstellen
my $xml_cur_doc = XML:
OM:
ocument->new();
$xml_cur_doc->createXMLDecl( '1.0', 'UTF-8' );
my $xml_cur_roo = undef;
my @parent_list = ();
# Die XML-Datei auswerten
for ( my $line_cur = 0 ; $line_cur < $line_tot ;
$line_cur++ ) {
SWITCH: for ( $file[$line_cur] ) {
# Importierte XML-Schemata vormerken und später
einlesen
/include schemaLocation=\"([\w|\.]+)\"/ && do { my
$filename = substr( $current_file, 0, rindex( $current_file, "/" ) + 1
) . $1; push ( @xmlfiles, $filename ); last; };
# Ein </element>-Tag schliesst ein Wrapper-Element
/<\/.*element>/ && do { my $x = shift
(@parent_list); last; };
# Referenz auf weitere Elemente/Datei überspringen
/element ref=\"(\w+)\"/ && do { last; };
# Normales Element - unter seinem Parent einordnen
und den Typ speichern
/element name=\"(\w+)\".*type=\"\w*?:*(\w+)\"/ &&
do {
my $child = $xml_cur_doc->createElement($1);
my ($parent) = @parent_list;
$parent->appendChild($child);
$self->{type}{$1} = $2;
last;
};
# Komplexes oder Wrapper-Element
/element name=\"(\w+)\"/ && do {
my $element = $1;
# Falls in den nächsten Zeilen "complexType"
und "Content" stehen ist es ein komplexes Element
if ( $file[ $line_cur + 1 ] =~ /complexType/
&& $file[ $line_cur + 2 ] =~ /Content/ ) {
my $child =
$xml_cur_doc->createElement($element);
my ($parent) = @parent_list;
$parent->appendChild($child);
my @enum_values = ();
until ( $file[ $line_cur - 1 ] =~
/<\/.*element\>/ ) {
if ( $file[$line_cur] =~ /enumeration
value=\"(.*?)\"/ ) { push ( @enum_values, $1 ); }
$line_cur++;
}
$self->{type}{$element} = "enum";
$self->{enum}{$element} = [@enum_values];
last;
# Ansonsten ist es ein Wrapper-Element das
als Parent fungiert
}
else {
my $parent =
$xml_cur_doc->createElement($element);
if ( defined $xml_cur_roo ) { my
($preparent) = @parent_list; $preparent->appendChild($parent); }
else { $xml_cur_roo = $parent; }
unshift ( @parent_list, $parent );
last;
}
}
}
}
# Das erzeugte XML-Dokument für diese Datei in einem Hash
ablegen - Index ist der Dateiname
$self->{template}{doc}{$current_file} = $xml_cur_doc;
$self->{template}{root}{$current_file} = $xml_cur_roo;
}
else {
die CText->get( $konfiguration, 1001, $current_file );
}
}
$self->{template}{root}{$rootfile}->setOwnerDocument( $self->{doc}
);
$self->{root} = $self->{template}{root}{$rootfile};
# In die Konfiguration die Referenz auf das XML-Objekt ablegen
$konfiguration->set_value( 'xml', $self );
# Einen Patienten anlegen
CXML->insert( $konfiguration, 'pat' );
if ($gui) { $gui->set_status(53); $gui->{main}->Unbusy; }
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um XML-File aus einer Datei einzulesen
#
#------------------------------------------------------------------------------#
sub read($$) {
my ( $self, $file, $konfiguration ) = @_;
if ( $konfiguration->get_value('gui') ) { return if
$konfiguration->get_value('gui')->create_confirm( CText->get(
$konfiguration, 950 ), $konfiguration ); }
if ( $konfiguration->get_value('gui') ) {
$konfiguration->get_value('gui')->set_status(54); }
my $parser = new XML:
OM:
arser( KeepCDATA => 1, ErrorContext =>
2 );
my $doc = $parser->parsefile($file);
unless ($doc) {
warn CText->get( $konfiguration, 1002 );
# Logfileeintrag
if ( defined $konfiguration->get_value('log') ) { CTools->log(
$konfiguration, 904 ); }
}
my $xml = $konfiguration->get_value('xml');
$xml->{'doc'} = $doc;
$xml->{'root'} = $doc;
close(XML);
# Nach dem Import werden in der internen Datendarstellung die
Umlaute als
# Umlaute und nicht codiert gefuehrt
for my $child ( $xml->{'root'}->getElementsByTagName('*') ) {
if ( $child->toString =~ /<!\[CDATA\[(.*?&#\d{3};.*?)\]\]>/ )
{
my $childdata = $1;
my @list = $child->getElementsByTagName('*');
if ( $#list eq -1 ) {
$childdata = CXML->code($childdata);
my $value_node =
$xml->{'doc'}->createCDATASection($childdata);
my $fc = $child->getFirstChild;
$child->replaceChild( $value_node, $fc );
}
}
}
# Logfileeintrag
if ( defined $konfiguration->get_value('log') ) { CTools->log(
$konfiguration, 905 ); }
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um die XML-Struktur in eine Datei zu schreiben
#
#------------------------------------------------------------------------------#
sub write($$) {
my ( $self, $konfiguration ) = @_;
# Dateinamen ermitteln, dazu ID ds angemeldeten Arztes, Vorname,
Nachname
# und Geburtsdatum ermitteln
my $arzt_id = $konfiguration->get_value('uid');
my $pat_data = CXML->extract_flattened( 'VCARDMOD', 'PATIENT', 0,
1, $konfiguration );
my $soz_data = CXML->extract_flattened( 'soziomedizinischedaten',
'', 0, 0, $konfiguration );
$pat_data =~
/<id>(\d+)<\/id>.*?<vorname><!\[CDATA\[(.*?)\]\]><\/vorname>.*?<nachname><!\[CDATA\[(.*?)\]\]><\/nachname>/;
return 0 unless $1 && $2 && $3;
my $file = join ( "-", ( $arzt_id, $1, $2, $3 ) );
$soz_data =~ /<geburtszeitpunkt>(\d+)-(\d+)-(\d+)\s/;
return 0 unless $1 && $2 && $3;
$file .= "-$3-$2-$1.epa";
# Datei zum schreiben öffnen
open( XML, ">$file" ) or die CText->get( $konfiguration, 1001,
$file );
# EPA auf Festplatte bringen
print XML xmlcode(
$konfiguration->get_value('xml')->{'root'}->toString );
close(XML);
if ( defined $konfiguration->get_value('log') ) { CTools->log(
$konfiguration, 906 ); }
return 1;
}
#------------------------------------------------------------------------------#
# Subroutine, um die bezeichnete Patientenakte von der Festplatte zu
entfernen #
#------------------------------------------------------------------------------#
sub delete($$) {
my ( $self, $filename, $konfiguration ) = @_;
if ( $konfiguration->get_value('gui') ) { return if
$konfiguration->get_value('gui')->create_confirm( CText->get(
$konfiguration, 951 ), $konfiguration ); }
unlink $filename;
if ( defined $konfiguration->get_value('log') ) { CTools->log(
$konfiguration, 907, $filename ); }
if ( $konfiguration->get_value('gui') ) {
$konfiguration->get_value('gui')->set_status(55); }
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um einen bestehenden Ast des XML-Schemas in einen
anderen zu #
# kopieren bzw. zu bewegen
#
#------------------------------------------------------------------------------#
sub copy ($$$$$$$) {
my ( $self, $from_major, $from, $from_id, $to, $to_id,
$to_element, $remove_source, $konfiguration ) = @_;
my $xml = $konfiguration->get_value('xml');
my $xmlroot = $xml->{'root'};
# Source-Bereich finden
for my $source ( $xmlroot->getElementsByTagName($from_major) ) {
for my $source ( $source->getElementsByTagName($from) ) {
# Anschliessend die ID des Bereiches suchen
for my $id_node ( $source->getElementsByTagName('id') ) {
# Und feststellen ob es die gewünschte ID ist
if ( $id_node->getFirstChild->toString =~
/^$from_id$/i ) {
# Falls dem so sein sollte, den Bereich (rekursiv)
kopieren...
my $nodecopy = $source->cloneNode(1);
# Eventuell die alte Node entfernen
if ($remove_source) { my $source_parent =
$source->getParentNode(); $source_parent->removeChild($source); }
# ...anschliessen den Zielabschnitt suchen
for my $destination (
$xmlroot->getElementsByTagName($to) ) {
# Anschliessend die ID des Ziels suchen
for my $id_node (
$destination->getElementsByTagName('id') ) {
# Und feststellen ob es die gewünschte ID
ist
if ( $id_node->getFirstChild->toString =~
/^$to_id$/i ) {
for my $destination (
$destination->getElementsByTagName($to_element) ) {
# Falls dem so sein sollte, den
kopierten Bereich anfügen
$destination->appendChild($nodecopy);
return;
}
}
}
}
}
}
}
}
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um ein Wert-Child zu entfernen
#
#------------------------------------------------------------------------------#
sub remove ($$$$) {
my ( $self, $abschnitt, $keyword, $element, $nr, $konfiguration )
= @_;
# Das XML-Objekt holen
my $xml = $konfiguration->get_value('xml');
my $xmlroot = $xml->{'root'};
my ( $abs, @values );
# Zuerst den Abschnitt suchen (z.B. 'anfragen')
if ($abschnitt) { ( $abs, @values ) =
$xml->{'root'}->getElementsByTagName($abschnitt); }
else { $abs = $xml->{'root'}; }
# Anschliessend den Unterabschnitt suchen (z.B. eine 'ANFRAGE')
my $nodes = $abs->getElementsByTagName($keyword);
# Falls es mehrere Unterabschnitte gibt den gewünschten auswählen
my $teil = $nodes->item($nr);
if ( defined $teil ) {
# Rekursiv im Unterabschnitt nach dem Tag dessen Wert gelöscht
werden soll suchen (z.B. fachrichtung)
for my $elem ( $teil->getElementsByTagName( $element, 1 ) ) {
# Falls dieser Tag ein Wert-Kind besitzt dieses löschen
my $value_child = $elem->getFirstChild;
$elem->removeChild($value_child) if defined $value_child;
}
}
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um die uebergebene XML-Struktur in das Gesamtschema
einzupflegen #
#------------------------------------------------------------------------------#
sub insert($$$) {
my ( $self, $konfiguration, $insert_this, $parent ) = @_;
my $xml = $konfiguration->get_value('xml');
my $xmlroot = $xml->{'root'};
my $xmlrootfile = $konfiguration->get_value('xmlrootfile');
SWITCH: for ($insert_this) {
/pat/ && do { $insert_this = "PATIENT"; $parent =
"patient"; last; };
/arz/ && do { $insert_this = "ARZT"; $parent =
"arztliste"; last; };
/par/ && do { $insert_this = "INSTITUTION"; $parent =
"paramedizinischeliste"; last; };
/ana/ && do { $insert_this = "ANAMNESE"; $parent =
"anamnesen"; last; };
/unt/ && do { $insert_this = "UNTERSUCHUNG"; $parent =
"untersuchungen"; last; };
/dia/ && do { $insert_this = "DIAGNOSE"; $parent =
"diagnosen"; last; };
/mas/ && do { $insert_this = "MASSNAHME"; $parent =
"massnahmen"; last; };
/anf/ && do { $insert_this = "ANFRAGE"; $parent =
"anfragen"; last; };
}
for my $parent_element ( $xmlroot->getElementsByTagName($parent) )
{
# Dateinamen für das einzusetzende Datenblatt bestimmen, da
der
# Dateiname als Index dient
my $insert_file = $xmlrootfile;
$insert_file =~ s/(.*\/)\w+(\.xsd)/$1$insert_this$2/i;
# Neue ID für das Element generieren
my $newid = 1;
my %oldid;
# Vorhandenen ID-Nodes suchen
my @id_nodes = $parent_element->getElementsByTagName( 'id', 1
);
my $id_anz = $#id_nodes;
# Wenn die Anzahl -1 ist, gibt es keine IDs
unless ( $id_anz < 0 ) {
# Vorhandene IDs auslesen
foreach my $id_node (@id_nodes) {
if ( $id_node->hasChildNodes ) { my $id =
$id_node->getFirstChild->toString; $oldid{$id} = 1; }
}
$newid++ while $oldid{$newid};
}
# Neues Element erzeugen
my $newelement =
$xml->{template}{root}{$insert_file}->cloneNode(1);
$newelement->setOwnerDocument( $xml->{doc} );
# Und die ID des Elementes setzen
for my $id_node ( $newelement->getElementsByTagName( 'id', 1 )
) { my $id_value = $xml->{doc}->createTextNode($newid);
$id_node->appendChild($id_value); }
# Falls die Arzt-ID als Erzeuger-ID gesetzt werden kann, dies
tun
for my $id_node ( $newelement->getElementsByTagName( 'arztid',
1 ) ) { my $id_value = $xml->{doc}->createTextNode(
$konfiguration->get_value('uid') ); $id_node->appendChild($id_value);
}
# Neues Element in den XML-Baum einpflegen
$parent_element->appendChild($newelement);
}
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um den Wert eines Elementes in einem XML-Abschnitt zu
aendern #
#------------------------------------------------------------------------------#
sub update($$$$$$) {
my ( $self, $element, $wert, $keyword, $abschnitt, $nr,
$konfiguration ) = @_;
print "ICH SOLL UPDATEN: ELEMENT $element AUF WERT $wert KEYWORD
$keyword ABSCHNITT $abschnitt NR $nr...\n";
# Das XML-Objekt holen
my $xml = $konfiguration->get_value('xml');
# Variablen der Subroutine deklarieren
my $count = 0;
# Den jeweiligen Abschnitt suchen
if ($abschnitt) { my @abschnitte =
$xml->{'root'}->getElementsByTagName($abschnitt); $abschnitt =
$abschnitte[0]; }
else { $abschnitt = $xml->{'root'}; }
print "SUCHE TEILABSCHNITT $nr, bin bei $count...\n";
# Suchen wir nach dem Element, das mit dem Keyword bezeichnet wird
for my $teil ( $abschnitt->getElementsByTagName($keyword) ) {
# Prüfen ob wir auch das richtige Keyword gefunden haben (z.B.
die VCARDMOD des 3. Arztes)
if ( $count eq $nr ) {
print "GEFUNDEN!\n";
# ...und dann den Tag sofern er existiert
for my $zieltag ( $teil->getElementsByTagName($element) )
{
print "ZIELTAG GEFUNDEN\n";
# Das Werte-Element des Zieltags erzeugen
my $new_value_element = CXML->create_value_element(
$wert, $zieltag, $xml, $konfiguration ) if $wert;
# Hat das Zielelement bereits ein Value-Kind?
if ( defined $zieltag->getFirstChild ) {
print "HAT CHILD\n";
# Wenn es bereits ein Value-Kind gibt das alte
ersetzen bzw. löschen falls Wert '' ist
my $old_value_element = $zieltag->getFirstChild;
if ( defined $wert && defined $new_value_element
&& $wert ) {
print "REPLACED\n";
$zieltag->replaceChild( $new_value_element,
$old_value_element );
}
else {
$zieltag->removeChild($old_value_element);
print "REMOVED\n";
}
}
else {
$zieltag->appendChild($new_value_element) if $wert
&& defined $new_value_element;
print "APPEND\n";
}
}
return 1;
}
# Wir gehen weiter in der Liste und suchen das naechste
Vorkommen (z. B.
# die VCARDMOD des naechsten Arztes)
$count++;
}
print "FERTIG!\n";
return 0;
}
#------------------------------------------------------------------------------#
# Subroutine, um aus dem Gesamtschema den durch das Keyword
beschriebenen Teil #
# auszulesen
#
#------------------------------------------------------------------------------#
sub extract($$$$) {
my ( $self, $keyword, $abschnitt, $nr, $konfiguration ) = @_;
# Das XML-Objekt holen
my $xml = $konfiguration->get_value('xml');
my $abs;
# Variablen der Subroutine deklarieren
my $count = 0;
my @values;
if ($abschnitt) { ( $abs, @values ) =
$xml->{'root'}->getElementsByTagName($abschnitt); }
else { $abs = $xml->{'root'}; }
my $nodes = $abs->getElementsByTagName($keyword);
my $total = $nodes->getLength;
my $teil = $nodes->item($nr);
my %valueshash;
if ( defined $teil ) {
# Alle Nodes aus dem Abschnitt holen
sub getallchildnodes {
my ( $node, $parentname, $valuesref, $hashref ) = @_;
# Child-Nodes jeder Node durchlaufen
foreach my $child ( $node->getChildNodes ) {
# Falls auch diese Node Kinder hat, rekursiv
durchlaufen
getallchildnodes( $child, $child->getNodeName,
$valuesref, $hashref ) if $child->hasChildNodes;
# Keine Kinder? Dann ist es eine Wert-Node - Wert
ermitteln bzw. '' setzen falls nicht initialisiert
my $value = defined $child->getNodeValue ?
$child->getNodeValue : '';
# Den Wert speichern unter dem Namen der Eltern-Node
unless ( defined $hashref->{ $child->getNodeName } &&
$hashref->{ $child->getNodeName } ne '' ) { $hashref->{
$child->getNodeName } = $value; }
unless ( defined $hashref->{$parentname} &&
$hashref->{$parentname} ne '' ) { $hashref->{$parentname} = $value; }
}
}
# Rekursive Funktion anstossen
getallchildnodes( $teil, $teil->getNodeName, \@values,
\%valueshash );
}
# Hash neu strukturieren
foreach my $tagname ( keys %valueshash ) { push ( @values, {
$tagname => $valueshash{$tagname} } ) unless $tagname =~
/cdata-section/; }
# Array mit der Gesamtzahl und den Werten zurückliefern
return ( $total, @values );
}
#------------------------------------------------------------------------------#
# Subroutine um aus dem Gesamtschema einen Teil als Scalar auszugeben
#
#------------------------------------------------------------------------------#
sub extract_flattened ($$$$$) {
my ( $self, $keyword, $abschnitt, $nr, $id, $konfiguration ) = @_;
# Das XML-Objekt holen
my $xml = $konfiguration->get_value('xml');
my ( $abs, @temp );
# Variablen der Subroutine deklarieren
my $count = 0;
if ($abschnitt) { ( $abs, @temp ) =
$xml->{'root'}->getElementsByTagName($abschnitt); }
else { $abs = $xml->{'root'}; }
my $nodes = $abs->getElementsByTagName($keyword);
# Suchen wir nach einer Nr oder einer ID?
if ( $id == 0 ) {
my $teil = $nodes->item($nr);
if ( defined $teil ) { return $teil->toString; }
}
else {
foreach my $teil ( @{$nodes} ) { return $teil->toString if
$teil->toString =~ /<id>$id<\/id>/; }
}
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um die gesamte EPA als String zu dumpen
#
#------------------------------------------------------------------------------#
sub extract_all_flattened ($) {
my ( $self, $konfiguration ) = @_;
return $konfiguration->get_value('xml')->{'root'}->toString;
}
#------------------------------------------------------------------------------#
# Subroutine, um die Daten für den Menuebutton einer Anfrage zu
generieren #
#------------------------------------------------------------------------------#
sub get_payload_data ($$$$$$) {
my ( $self, $nr, $konfiguration, $existref, $picksref, $beref ) =
@_;
# Das XML-Objekt holen
my $xml = $konfiguration->get_value('xml');
my $xmlroot = $xml->{'root'};
# Die vorhandenen Anamnesen, Untersuchungen, Diagnosen und
Massnahmen suchen
foreach my $area (qw/ANAMNESE UNTERSUCHUNG DIAGNOSE MASSNAHME/) {
foreach my $entity ( $xmlroot->getElementsByTagName($area) ) {
# Nach der ID suchen
my $entity_text = $entity->toString;
$entity_text =~ /<id>(\d+)<\/id>/;
my $id = $1;
push @{ $existref->{"\L$area\E"} }, $id;
$picksref->{"\L$area\E"}->{$id} = 0;
SWITCH: for ($area) {
/ANAMNESE/ && do {
$entity_text =~
/<text>.*?CDATA\[(.*?)\].*?<\/text>.*?<anamnesezeitpunkt>(\d+)\D(\d+)\D(\d+)\s/;
my ( $b, $j, $m, $t ) = ( $1, $2, $3, $4 );
$b = "Anamnese" unless $b;
$j = "??" unless $j;
$m = "??" unless $m;
$t = "??" unless $t;
$beref->{'anamnese'}->{$id} = substr( code($b), 0,
40 ) . " ($t.$m.$j)";
last;
};
/UNTERSUCHUNG/ && do {
$entity_text =~
/<untersuchungsbezeichnung>(.*?)<\/untersuchungsbezeichnung>.*?<untersuchungszeitpunkt>(\d+)\D(\d+)\D(\d+)\s/;
my ( $b, $j, $m, $t ) = ( $1, $2, $3, $4 );
$b = "Untersuchung" unless $b;
$j = "??" unless $j;
$m = "??" unless $m;
$t = "??" unless $t;
$beref->{'untersuchung'}->{$id} = substr(
code($b), 0, 40 ) . " ($t.$m.$j)";
last;
};
/DIAGNOSE/ && do {
$entity_text =~
/<diagnosetyp>.*?CDATA\[(.*?)\].*?<\/diagnosetyp>.*?<diagnosezeitpunkt>(\d+)\D(\d+)\D(\d+)\s/;
my ( $b, $j, $m, $t ) = ( $1, $2, $3, $4 );
$b = "Diagnose" unless $b;
$j = "??" unless $j;
$m = "??" unless $m;
$t = "??" unless $t;
$beref->{'diagnose'}->{$id} = substr( code($b), 0,
40 ) . " ($t.$m.$j)";
last;
};
/MASSNAHME/ && do {
$entity_text =~
/<bezeichnung>.*?CDATA\[(.*?)\].*?<\/bezeichnung>.*?<zeitpunktbeginn>(\d+)\D(\d+)\D(\d+)\s/;
my ( $b, $j, $m, $t ) = ( $1, $2, $3, $4 );
$b = "Massnahme" unless $b;
$j = "??" unless $j;
$m = "??" unless $m;
$t = "??" unless $t;
$beref->{'massnahme'}->{$id} = substr( code($b),
0, 40 ) . " ($t.$m.$j)";
last;
};
}
}
}
# Feststellen, welche Daten als zu senden gespeichert sind
my $anfrageliste = $xmlroot->getElementsByTagName('ANFRAGE');
my $anfrage = $anfrageliste->item($nr);
my $datentransmit =
$anfrage->getElementsByTagName('datentransmit')->item(0) if defined
$anfrage;
my $idstring = $datentransmit->toString if defined
$datentransmit;
while ( defined $idstring && $idstring =~ /<(\w+)id>(\d+)</ ) {
my $type = $1;
my $id = $2;
$picksref->{$type}->{$id} = 1;
$idstring =~ s/<($type)id>$id<\/($type)id>//;
}
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um die Daten für den Menuebutton einer Anfrage
festzulegen #
#------------------------------------------------------------------------------#
sub set_payload_data ($$$$) {
my ( $self, $nr, $konfiguration, $typ, $id, $status ) = @_;
# Das XML-Objekt holen
my $xml = $konfiguration->get_value('xml');
my $xmlroot = $xml->{'root'};
# Feststellen, welche Daten als zu senden gespeichert sind
my $anfrageliste = $xmlroot->getElementsByTagName('ANFRAGE');
my $anfrage = $anfrageliste->item($nr);
my $datentransmit =
$anfrage->getElementsByTagName('datentransmit')->item(0) if defined
$anfrage;
my $tagname = $typ . "id";
if ($status) {
# ID zur Payload hinzufügen
my $value_element = $xml->{'doc'}->createElement($tagname);
my $value_child = $xml->{'doc'}->createTextNode("$id");
$datentransmit->appendChild($value_element);
$value_element->appendChild($value_child);
}
else {
# Die ID aus der Payload wieder entfernen
foreach my $child (
$datentransmit->getElementsByTagName($tagname) ) {
$datentransmit->removeChild($child) if $child->toString =~
/>$id</;
}
}
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um die Daten für die Direktauswahl zu generieren
#
#------------------------------------------------------------------------------#
sub get_directpick_data ($$) {
my ( $self, $konfiguration, $layout, $optionsref ) = @_;
# Das XML-Objekt holen
my $xml = $$konfiguration->get_value('xml');
my $xmlroot = $xml->{'root'};
# Die vorhandenen Abschnitte suchen
my $area;
$area = "ARZT" if $$layout eq "arz";
$area = "INSTITUTION" if $$layout eq "par";
$area = "ANAMNESE" if $$layout eq "ana";
$area = "UNTERSUCHUNG" if $$layout eq "unt";
$area = "DIAGNOSE" if $$layout eq "dia";
$area = "MASSNAHME" if $$layout eq "mas";
$area = "ANFRAGE" if $$layout eq "anf";
# Laufende Nummer mitzaehlen
my $nr = 0;
foreach my $entity ( $xmlroot->getElementsByTagName($area) ) {
my $entity_text = $entity->toString;
my $text;
SWITCH: for ($area) {
/ARZT/ && do {
$entity_text =~ /<vorname>.*?CDATA\[(.*?)\]/;
my $v = ( $1 ? $1 : "??" );
$entity_text =~ /<nachname>.*?CDATA\[(.*?)\]/;
my $n = ( $1 ? $1 : "??" );
$text = "$v $n";
last;
};
/INSTITUTION/ && do { # dgraf
$entity_text =~ /<vorname>.*?CDATA\[(.*?)\]/;
my $v = ( $1 ? $1 : "??" );
$entity_text =~ /<nachname>.*?CDATA\[(.*?)\]/;
my $n = ( $1 ? $1 : "??" );
$text = "$v $n";
last;
};
/ANAMNESE/ && do {
$entity_text =~ /<text>.*?CDATA\[(.*?)\]/;
my $t = ( $1 ? $1 : "Anamnese" );
$entity_text =~
/<anamnesezeitpunkt>(\d+)\D(\d+)\D(\d+)\s/;
my $d = ( $1 ? "$3.$2.$1" : "??.??.??" );
$text = substr( code($t), 0, 40 ) . " $d";
last;
};
/UNTERSUCHUNG/ && do {
$entity_text =~
/<untersuchungsbezeichnung>.*?CDATA\[(.*?)\]/;
my $t = ( $1 ? $1 : "Untersuchung" );
$entity_text =~
/<untersuchungszeitpunkt>(\d+)\D(\d+)\D(\d+)\s/;
my $d = ( $1 ? "$3.$2.$1" : "??.??.??" );
$text = substr( code($t), 0, 40 ) . " $d";
last;
};
/DIAGNOSE/ && do {
$entity_text =~ /<diagnosetyp>.*?CDATA\[(.*?)\]/;
my $t = ( $1 ? $1 : "Diagnose" );
$entity_text =~
/<diagnosezeitpunkt>(\d+)\D(\d+)\D(\d+)\s/;
my $d = ( $1 ? "$3.$2.$1" : "??.??.??" );
$text = substr( code($t), 0, 40 ) . " $d";
last;
};
/MASSNAHME/ && do {
$entity_text =~ /<bezeichnung>.*?CDATA\[(.*?)\]/;
my $t = ( $1 ? $1 : "Massnahme" );
$entity_text =~
/<zeitpunktbeginn>(\d+)\D(\d+)\D(\d+)\s/;
my $d = ( $1 ? "$3.$2.$1" : "??.??.??" );
$text = substr( code($t), 0, 40 ) . " $d";
last;
};
/ANFRAGE/ && do {
$entity_text =~ /<anfragetext>.*?CDATA\[(.*?)\]/;
my $t = ( $1 ? $1 : "Anfrage" );
$entity_text =~
/<anfragezeitpunkt>(\d+)\D(\d+)\D(\d+)\s/;
my $d = ( $1 ? "$3.$2.$1" : "??.??.??" );
$text = substr( code($t), 0, 40 ) . " $d";
last;
};
}
# Umlaute und andere Sonderzeichen entfernen
$text =~ tr/äöüßÄÖÜ/aousAOU/;
$text =~ s/&#\d{2,};//g;
push @{$optionsref}, [ $text, $nr++ ];
}
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um die Daten der Belege einer Untersuchung auszulesen
#
#------------------------------------------------------------------------------#
sub get_untbelege($$) {
my ( $self, $konfiguration, $nr ) = @_;
# Das XML-Objekt holen
my $xml = $konfiguration->get_value('xml');
my $xmlroot = $xml->{'root'};
# Array fuer Daten der Belege
my @belegdaten;
# Zuerst den Abschnitt 'UNTERSUCHUNG' suchen und die richtige
Nummer nehmen
my $untersuchungen =
$xmlroot->getElementsByTagName("UNTERSUCHUNG");
my $untersuchung = $untersuchungen->item($nr);
# In der Untersuchung alle Belege durchgehen
foreach my $beleg ( $untersuchung->getElementsByTagName("beleg") )
{
my $result;
$result->{'beschreibung'} =
$beleg->getElementsByTagName("beschreibung")->item(0)->getFirstChild->getNodeValue
if
$beleg->getElementsByTagName("beschreibung")->item(0)->hasChildNodes;
$result->{'daten'} =
$beleg->getElementsByTagName("daten")->item(0)->getFirstChild->getNodeValue
if $beleg->getElementsByTagName("daten")->item(0)->hasChildNodes;
push ( @belegdaten, $result ) if defined
$result->{'beschreibung'} && $result->{'beschreibung'};
}
return @belegdaten;
}
#------------------------------------------------------------------------------#
# Subroutine, um Untersuchungsbelege eingeben zu koennen
#
#------------------------------------------------------------------------------#
sub insert_untbeleg($$) {
my ( $self, $konfiguration, $nr, $beschreibung, $daten ) = @_;
# UTF8-Coding in XML Numerischen Character Encoding wandeln
$beschreibung =~ s/([^\x20-\x7F])/'&#' . ord($1) . ';'/gse;
# Die Encodings in Umlaute wandeln
$beschreibung = code($beschreibung);
# Das XML-Objekt holen
my $xml = $konfiguration->get_value('xml');
my $xmlroot = $xml->{'root'};
# Zuerst den Abschnitt 'Belege' suchen und die richtige Nummer
nehmen
# Da jede Untersuchung genau einen Abschnitt 'Belege' hat, ist die
Nr. der
# Belege mit der Nr. der Untersuchung identisch...
my $untersuchungen = $xmlroot->getElementsByTagName("belege");
my $belege = $untersuchungen->item($nr);
# Anschliessend einen Beleg erzeugen
my $belegelement = $xml->{'doc'}->createElement('beleg');
my $beschreibungselement =
$xml->{'doc'}->createElement('beschreibung');
my $datenelement = $xml->{'doc'}->createElement('daten');
my $beschreibungsnode =
$xml->{'doc'}->createCDATASection($beschreibung);
my $datennode =
$xml->{'doc'}->createCDATASection($daten);
# Daten an die Elemente anfügen
$beschreibungselement->appendChild($beschreibungsnode);
$datenelement->appendChild($datennode);
# Elemente unter dem Beleg anfügen
$belegelement->appendChild($beschreibungselement);
$belegelement->appendChild($datenelement);
# Beleg anfügen
$belege->appendChild($belegelement);
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um Untersuchungs-Belege zu loeschen
#
#------------------------------------------------------------------------------#
sub delete_untbeleg($$) {
my ( $self, $konfiguration, $nr, $belegnr ) = @_;
# Das XML-Objekt holen
my $xml = $konfiguration->get_value('xml');
my $xmlroot = $xml->{'root'};
# Zuerst den Abschnitt 'Belege' suchen und die richtige Nummer
nehmen
# Da jede Untersuchung genau einen Abschnitt 'Belege' hat, ist die
Nr. der
# Belege mit der Nr. der Untersuchung identisch ....
my $untersuchungen = $xmlroot->getElementsByTagName("belege");
my $belege = $untersuchungen->item($nr);
# Anschliessend den zu loeschenden Beleg finden
my $belegliste = $belege->getElementsByTagName("beleg");
my $beleg = $belegliste->item($belegnr);
# Beleg entfernen
$belege->removeChild($beleg);
return;
}
#------------------------------------------------------------------------------#
# Subroutine, um encodierte Sonderzeichen zu decodieren bzw.
umgekehrt; #
# abhaengig davon, ob &# ... ; in dem String vorkommt oder nicht
#
#------------------------------------------------------------------------------#
sub code ($) {
my ( $self, $char ) = @_;
$char = $self unless defined $char;
if ( defined $char && $char =~ /&#\d+;/ ) {
# Ampersand rauswerfen
$char =~ s/&?#195;//g;
$char =~ s/&//g;
# Lower Bit UTF
$char =~ s/&?#159;/ß/g;
$char =~ s/&?#164;/ä/g;
$char =~ s/&?#182;/ö/g;
$char =~ s/&?#188;/ü/g;
$char =~ s/&?#132;/Ä/g;
$char =~ s/&?#150;/Ö/g;
$char =~ s/&?#156;/Ü/g;
# XML Numeric Character Encoding
$char =~ s/&?#223;/ß/g;
$char =~ s/&?#228;/ä/g;
$char =~ s/&?#246;/ö/g;
$char =~ s/&?#252;/ü/g;
$char =~ s/&?#196;/Ä/g;
$char =~ s/&?#214;/Ö/g;
$char =~ s/&?#220;/Ü/g;
}
return $char;
}
#------------------------------------------------------------------------------#
# Subroutine, um Umlaute nach XML-Entitaeten zu konvertieren
#
#------------------------------------------------------------------------------#
sub xmlcode ($) {
my $char = shift;
$char =~ s/ß/ß/g;
$char =~ s/ä/ä/g;
$char =~ s/ö/ö/g;
$char =~ s/ü/ü/g;
$char =~ s/Ä/Ä/g;
$char =~ s/Ö/Ö/g;
$char =~ s/Ü/Ü/g;
return $char;
}
#------------------------------------------------------------------------------#
# Subroutine, um ein korrektes Element für den Wert eines Tag zu
erstellen und #
# ggf. Korrekturfilter anzuwenden auf importierte Daten
#
# Die Ueberpruefung von int/long hat z. Zt. keinen tieferen Zweck und
dient #
# nur der Sicherheit, dass alle Werte korrekt sind (Begrenzungswerte
sind fuer #
# "signed"-Typen eines typischen C/C++-Compilers auf x86 Architektur
ausgelegt #
# - ggf. anpassen)
#
#------------------------------------------------------------------------------#
sub create_value_element ($$$) {
my ( $self, $import_value, $zieltag, $xml, $konfiguration ) = @_;
my $type = $xml->{type}{ $zieltag->getTagName };
my $value_node = undef;
# UTF8-Coding in XML Numerischen Character Encoding wandeln
$import_value =~ s/([^\x20-\x7F])/'&#' . ord($1) . ';'/gse unless
$type eq 'base64Binary';
# Die Encodings in Umlaute wandeln
$import_value = code($import_value) unless $type eq
'base64Binary';
SWITCH: for ($type) {
/string/ && do {
if ( $import_value =~ /[\w]/ ) { $value_node =
$xml->{'doc'}->createCDATASection($import_value) }
last;
};
/dateTime/ && do {
if ( $import_value =~ /[\d|-]+/ ) { $value_node =
$xml->{'doc'}->createTextNode( date_iso($import_value) ) }
last;
};
/dateTimefix/ && do {
if ( $import_value =~ /[\d|-]+/ ) { $value_node =
$xml->{'doc'}->createTextNode( date_iso($import_value) ) }
last;
};
/long/ && do {
if ( $import_value =~ /\d*/ && $import_value < 2147483647
) { $value_node = $xml->{'doc'}->createTextNode($import_value) }
last;
};
/int/ && do {
if ( $import_value =~ /\d*/ && $import_value < 32767 ) {
$value_node = $xml->{'doc'}->createTextNode($import_value) }
last;
};
/enum/ && do {
foreach my $value_allowed ( @{ $xml->{enum}{
$zieltag->getTagName } } ) {
if ( $import_value eq $value_allowed ) { $value_node =
$xml->{'doc'}->createTextNode($import_value); }
elsif ( convert_value( $import_value, $value_allowed )
) { $value_node = $xml->{'doc'}->createTextNode($value_allowed); }
}
last;
};
/base64Binary/ && do { $value_node =
$xml->{doc}->createCDATASection($import_value); last; };
die CText->get( $konfiguration, 1003, $_ );
}
return $value_node;
}
#------------------------------------------------------------------------------#
# Subroutine, um einen Wert auf einen Enumerationswert hinzubiegen,
falls #
# maeglich - TRUE zurückgeben, falls das geht, ansonsten FALSE
#
#------------------------------------------------------------------------------#
sub convert_value ($$) {
my ( $iv, $av ) = @_;
SWITCH: for ($av) {
/männlich/ && do {
if ( $iv =~ /^m/ ) { $iv = 1; last; }
};
/weiblich/ && do {
if ( $iv =~ /^[wf]/ ) { $iv = 1; last; }
};
$iv = 0;
}
return $iv;
}
#------------------------------------------------------------------------------#
# Subroutine, um ein Datum in ein ISO-konformes Format "YYYY-MM-TT
HH:MM:SS" #
# zu bringen
#
#------------------------------------------------------------------------------#
sub date_iso ($) {
my ( $self, $date ) = @_;
$date = $self unless defined $date;
my $iso = "";
if ( $date =~ /(\d{1,2})\.(\d{1,2})\.(\d{2}\d*)(.*)/ ) {
# Deutsches Datum
my $time = $4;
$iso = "$3-$2-$1 ";
if ( defined $time && $time =~
/(\d{1,2})\D(\d{1,2})\D(\d{1,2})/ ) { $iso .= "$1:$2:$3"; }
else { $iso .= "00:00:00"; }
}
elsif ( $date =~ /(\d{4})\D(\d{2})\D(\d{2})
(\d{2})\D(\d{2})\D(\d{2})/ ) {
# ISO-Datum
my $iso = "$3.$2.$1 ($4:$5:$6)";
}
return $iso;
}
-----------------------------------------------
Sincerely
Markus
