MDXMLFM ; HOIFO/DP - Fileman -> XML Utilities ; [01-10-2003 09:14]
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
; Integration Agreements:
; IA# 10035 [Supported] ^DPT references
;
; Special note: This routine assumes RESULTS contains the closed
; root specification, ^TMP($J) where the output of
; these calls will go.
; i.e. S RESULTS=$NA(^TMP($J))
;
; Calling app needs to call NEWDOC^MDXMLFM *ONCE*
; to clear the global before building an XML document.
;
LOADALL(IENLIST,DD,FLDS) ; Load complete dataset
;
; Loads entire dataset from @IENLIST@(...)
;
N MDIEN S MDIEN=0
D NEWDOC("RESULTS")
D XMLDATA("STATUS","OK")
F S MDIEN=$O(@IENLIST@(MDIEN)) Q:'MDIEN D
.D BLDXML(DD,MDIEN,.FLDS)
D ENDDOC("RESULTS")
Q
;
LOADONE(IEN,DD,FLDS) ; Load single record as dataset
;
; Not to be used recursively
; Assumes complete data set is one record
;
D NEWDOC("RESULTS")
D XMLDATA("STATUS","OK")
D BLDXML(DD,IEN,.FLDS)
D ENDDOC("RESULTS")
Q
;
LOADFILE(MDNUM,MDROOT,MDFLDS) ; Bulk load file MDNUM into XML
;
; Loads all records and all fields in the DD# MDNUM
; Optionally include a closed root of the index to use MDROOT
; Optionally include a list of fields #;#;#;# will default to "*"
;
N MDIEN,MDNODE,MDIDS,MDTEMP,MDHDR,MDNAME
S MDTEMP=$NA(^TMP("MD_TEMP",$J)) K @MDTEMP
S MDNAME=$$GET1^DID(MDNUM,,,"NAME")
I $G(MDROOT)]"" S:'$D(@MDROOT)#2 MDROOT=""
S:$G(MDROOT)="" MDROOT=$$ROOT^DILFD(MDNUM,,1)
S:$G(MDFLDS)="" MDFLDS="*"
;
; Load the records via Fileman GETS^DIQ
;
S MDIEN=0
F S MDIEN=$O(@MDROOT@(MDIEN)) Q:'MDIEN D
.D GETS^DIQ(MDNUM,MDIEN_",",MDFLDS,"I",MDTEMP)
;
; Grab the tags and types if any records were processed
;
S MDIEN=$O(@MDTEMP@(MDNUM,"")) D:MDIEN]""
.F X=0:0 S X=$O(@MDTEMP@(MDNUM,MDIEN,X)) Q:'X D
..S MDTAG=$$GET1^DID(MDNUM,X,,"LABEL")
..S MDTYPE=$$GET1^DID(MDNUM,X,,"TYPE")
..S MDPTR=$$GET1^DID(MDNUM,X,,"POINTER")
..S @MDTEMP@(MDNUM,0,X,"TAG")=$$TAGSAFE(MDTAG)
..S @MDTEMP@(MDNUM,0,X,"TYPE")=MDTYPE
..S @MDTEMP@(MDNUM,0,X,"PTR")=MDPTR
;
; Ok, lets add the file
;
D XMLDATA("TABLENAME",MDNAME)
S MDIENS=$O(@MDTEMP@(MDNUM,0))
F Q:MDIENS="" D
.D XMLHDR("RECORD")
.S MDFLD=$O(@MDTEMP@(MDNUM,MDIENS,0))
.F Q:MDFLD="" D
..S MDTAG=@MDTEMP@(MDNUM,0,MDFLD,"TAG")
..S MDATA=@MDTEMP@(MDNUM,MDIENS,MDFLD,"I")
..S MDTYPE=@MDTEMP@(MDNUM,0,MDFLD,"TYPE") D
...I MDTYPE["WORD" D XMLWP(MDTAG,MDATA) Q
...I MDTYPE["DATE" D XMLDT(MDTAG,MDATA) Q
...D XMLDATA(MDTAG,MDATA)
..S MDFLD=$O(@MDTEMP@(MDNUM,MDIENS,MDFLD))
.D XMLFTR("RECORD")
.S MDIENS=$O(@MDTEMP@(MDNUM,MDIENS))
Q
;
BLDFLD(RESULTS,DD,FLDS) ; Add a field or field^field to the FLDS array
F D Q:FLDS']""
.S Y=$P(FLDS,"^",1),FLDS=$P(FLDS,"^",2,250)
.S MDFLD=$P(Y,";",1) K RESULTS(MDFLD)
.I $P(Y,";",2)]"" S RESULTS(MDFLD,"FORMAT")=$P(Y,";",2)
.E S RESULTS(MDFLD,"FORMAT")="I"
.I $P(Y,";",3)]"" S RESULTS(MDFLD,"TAG")=$P(Y,";",3)
.E S RESULTS(MDFLD,"TAG")=$TR($$GET1^DID(DD,MDFLD,"","LABEL")," ","_")
.I $P(Y,";",4)]"" S RESULTS(MDFLD,"TYPE")=$P(Y,";",4)
.E S RESULTS(MDFLD,"TYPE")=$$GET1^DID(DD,+MDFLD,"","TYPE")
Q
;
BLDXML(DD,IEN,FLDS) ; Builds an XML Record based on DD, IEN, and FLDS
; Note: this is a standalone module requiring DD and IEN
; so that it can be easily used by the custom query routines
N MDFLD,MDIENS,X,Y
D XMLHDR("RECORD")
S MDIENS=IEN_",",MDFLD=""
F S MDFLD=$O(FLDS(MDFLD)) Q:MDFLD="" D
.; .001 is always the IEN *IF* it is included in the view
.I +MDFLD=.001 D XMLDATA(FLDS(MDFLD,"TAG"),+MDIENS) Q
.S MDFMT=$G(FLDS(MDFLD,"FORMAT"),"I")
.; Process as a date
.I $G(FLDS(MDFLD,"TYPE"))["DATE" D Q
..S X=$$GET1^DIQ(DD,MDIENS,MDFLD,"I")
..I X]""&(MDFMT'="I") D S X=Y
...S Y=($E(X,1,3)+1700)_"-"_$E(X,4,5)_"-"_$E(X,6,7) Q:X'["."
...S X=X+.0000001 ; Add it in ensure all the time parts
...S Y=Y_" "_$E(X,9,10)_":"_$E(X,11,12)_":"_$E(X,13,14)
..D XMLDATA(FLDS(MDFLD,"TAG"),X)
.; Process as WP
.I $G(FLDS(MDFLD,"TYPE"))["WORD" D Q
..D XMLHDR(FLDS(MDFLD,"TAG"))
..S Y=$O(@RESULTS@(""),-1)+1
..S X=$$GET1^DIQ(DD,MDIENS,MDFLD,"",$NA(@RESULTS@(Y)))
..D XMLFTR(FLDS(MDFLD,"TAG"))
.; Just return with specified data format
.I ($G(FLDS(MDFLD,"TYPE"))["SET")&(DD=704.202)&(MDFLD=.09) D Q
..I $$GET1^DIQ(DD,MDIENS,MDFLD,MDFMT)["DISABLED" D XMLDATA(FLDS(MDFLD,"TAG"),$$GET1^DIQ(DD,MDIENS,MDFLD,MDFMT)) Q
..L +^MDK(704.202,+MDIENS):1
..I '$T D XMLDATA(FLDS(MDFLD,"TAG"),"IN_USE") Q
..E L -^MDK(704.202,+MDIENS) D XMLDATA(FLDS(MDFLD,"TAG"),$$GET1^DIQ(DD,MDIENS,MDFLD,MDFMT))
..Q
.D XMLDATA(FLDS(MDFLD,"TAG"),$$GET1^DIQ(DD,MDIENS,MDFLD,MDFMT))
D XMLFTR("RECORD")
Q
;
XMLCMT(COMMENT) ; Add a comment to a document
D XMLADD("<!-- "_COMMENT_" -->")
Q
;
XMLHDR(TAG) ; Add a header tag to the global
S TAG=$$TAGSAFE(TAG)
D XMLADD("<"_TAG_">")
Q
;
XMLFTR(TAG) ; Add a footer tag to the global
D XMLHDR("/"_TAG)
Q
;
XMLDATA(TAG,X) ; Add a data element to the global
S TAG=$$TAGSAFE(TAG)
I $G(X)="" D XMLADD("<"_TAG_" />")
E D XMLADD("<"_TAG_">"_$$XMLSAFE(X)_"</"_TAG_">")
Q
;
XMLPT(X) ; Add a standard pt identifier node
S X(1,"NAME")=$P(^DPT(X,0),U)
S X(2,"SSN")=$P(^DPT(X,0),U,9)
S X(3,"SEX")=$P(^DPT(X,0),U,2)
S Y=$P(^DPT(X,0),U,3)
S Y(1)=1700+$E(Y,1,3),Y(2)=+$E(Y,4,5),Y(3)=+$E(Y,6,7)
S X(4,"DOB_Y")=Y(1)
S X(5,"DOB_M")=Y(2)
S X(6,"DOB_D")=Y(3)
D XMLIDS("PATIENT",.X,1)
Q
;
XMLWP(TAG,X) ; Add text in array @X to the global
S TAG=$$TAGSAFE(TAG)
I $G(X)="" D XMLADD("<"_TAG_" />") Q ; Empty global ref
D XMLHDR(TAG)
F Y=0:0 S Y=$O(@X@(Y)) Q:'Y D XMLADD(@X@(Y))
D XMLFTR(TAG)
Q
;
XMLDT(TAG,X) ; Add date or date/time to the global
S TAG=$$TAGSAFE(TAG)
I $G(X)="" D XMLADD("<"_TAG_" />") Q ; No data
; Build the ID array
S X(1,"Y")=(1700+$E(X,1,3))
S X(2,"M")=+$E(X,4,5)
S X(3,"D")=+$E(X,6,7)
D:X]"."
.S X=X+.0000001
.S X(4,"hh")=+$E(X,9,10)
.S X(5,"mm")=+$E(X,11,12)
.S X(6,"ss")=+$E(X,13,14)
D XMLIDS(TAG,.X,1)
Q
;
XMLIDS(TAG,IDS,CLOSE) ; Add a data element to the global with ids
S TAG="<"_$$TAGSAFE(TAG)
F X=0:0 S X=$O(IDS(X)) Q:'X D
.S Y="" F S Y=$O(IDS(X,Y)) Q:Y="" D
..S TAG=TAG_" "_Y_"="""_$$XMLSAFE(IDS(X,Y))_""""
S:$G(CLOSE) TAG=TAG_" /" ; Close out the tag element
S TAG=TAG_">"
D XMLADD(TAG)
Q
;
XMLADD(X) ; Add to the global
S @RESULTS@($O(@RESULTS@(""),-1)+1)=$G(X)
Q
;
ADDERR(X) ;
S MDERROR($O(MDERR(""),-1)+1)=X
Q
;
XMLOK(RESULTS) ; Build an XML OK message
K @RESULTS
S @RESULTS@(0)="<RESULTS>"
S @RESULTS@(1)="<STATUS>OK</STATUS>"
S @RESULTS@(2)="</RESULTS>"
Q
;
XMLERR(ERRMSG) ; Build an XML error Message to return
K @RESULTS
S @RESULTS@(0)="<RESULTS>"
S @RESULTS@(1)="<STATUS>ERROR</STATUS>"
I $D(ERRMSG)=1 D ; Simple one liner
.S @RESULTS@(2)="<MESSAGE>"_$$XMLSAFE(ERRMSG)_"</MESSAGE>"
I $D(ERRMSG)>2 D ; Load the array into the XML message
.S @RESULTS@(2)="<MESSAGE>"_$G(ERRMSG,"NO DESCRIPTION")
.S X="ERRMSG" F S X=$Q(@X) Q:X=""!(X'?1"ERRMSG(".E) D
..S @RESULTS@($O(@RESULTS@(""),-1)+1)=$$XMLSAFE(@X)
.S @RESULTS@($O(@RESULTS@(""),-1)+1)="</MESSAGE>"
S @RESULTS@($O(@RESULTS@(""),-1)+1)="</RESULTS>"
Q
;
XMLDATE(X) ; Transform Y into XML safe date
N Y
S Y=($E(X,1,3)+1700)_"-"_$E(X,4,5)_"-"_$E(X,6,7)
D:X["."
.S X=X+.0000001
.S Y=Y_" "_$E(X,9,10)_":"_$E(X,11,12)_":"_$E(X,13,14)
Q Y
;
XMLSAFE(X) ; Transform X into XML safe data
S X=$$TRNSLT(X,"&","&")
S X=$$TRNSLT(X,"<","<")
S X=$$TRNSLT(X,">",">")
S X=$$TRNSLT(X,"'","'")
S X=$$TRNSLT(X,"""",""")
Q X
;
TAGSAFE(X) ; Transform X into XML tag
S:X?1N.E X="_"_X ; Remove starting numeric
Q $TR(X," '`()<>*[]","__________")
;
NEWDOC(ROOT,COMMENT) ; Start a new document
K @RESULTS
D XMLADD("<?xml version=""1.0"" standalone=""yes""?>")
I $G(COMMENT)]"" D XMLCMT(COMMENT)
D XMLHDR($G(ROOT,"RESULTS"))
Q
;
ENDDOC(ROOT) ; End this document
D XMLFTR($G(ROOT,"RESULTS"))
Q
;
TRNSLT(X,X1,X2) ; Translate every Y to Z in X
N Y
Q:X'[X1 X ; Nothing to translate
S Y="" F Q:X="" D
.I X[X1 S Y=Y_$P(X,X1)_X2,X=$P(X,X1,2,250) Q
.S Y=Y_X,X=""
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDXMLFM 8287 printed Apr 09, 2024@20:47:28 Page 2
MDXMLFM ; HOIFO/DP - Fileman -> XML Utilities ; [01-10-2003 09:14]
+1 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+2 ; Integration Agreements:
+3 ; IA# 10035 [Supported] ^DPT references
+4 ;
+5 ; Special note: This routine assumes RESULTS contains the closed
+6 ; root specification, ^TMP($J) where the output of
+7 ; these calls will go.
+8 ; i.e. S RESULTS=$NA(^TMP($J))
+9 ;
+10 ; Calling app needs to call NEWDOC^MDXMLFM *ONCE*
+11 ; to clear the global before building an XML document.
+12 ;
LOADALL(IENLIST,DD,FLDS) ; Load complete dataset
+1 ;
+2 ; Loads entire dataset from @IENLIST@(...)
+3 ;
+4 NEW MDIEN
SET MDIEN=0
+5 DO NEWDOC("RESULTS")
+6 DO XMLDATA("STATUS","OK")
+7 FOR
SET MDIEN=$ORDER(@IENLIST@(MDIEN))
if 'MDIEN
QUIT
Begin DoDot:1
+8 DO BLDXML(DD,MDIEN,.FLDS)
End DoDot:1
+9 DO ENDDOC("RESULTS")
+10 QUIT
+11 ;
LOADONE(IEN,DD,FLDS) ; Load single record as dataset
+1 ;
+2 ; Not to be used recursively
+3 ; Assumes complete data set is one record
+4 ;
+5 DO NEWDOC("RESULTS")
+6 DO XMLDATA("STATUS","OK")
+7 DO BLDXML(DD,IEN,.FLDS)
+8 DO ENDDOC("RESULTS")
+9 QUIT
+10 ;
LOADFILE(MDNUM,MDROOT,MDFLDS) ; Bulk load file MDNUM into XML
+1 ;
+2 ; Loads all records and all fields in the DD# MDNUM
+3 ; Optionally include a closed root of the index to use MDROOT
+4 ; Optionally include a list of fields #;#;#;# will default to "*"
+5 ;
+6 NEW MDIEN,MDNODE,MDIDS,MDTEMP,MDHDR,MDNAME
+7 SET MDTEMP=$NAME(^TMP("MD_TEMP",$JOB))
KILL @MDTEMP
+8 SET MDNAME=$$GET1^DID(MDNUM,,,"NAME")
+9 IF $GET(MDROOT)]""
if '$DATA(@MDROOT)#2
SET MDROOT=""
+10 if $GET(MDROOT)=""
SET MDROOT=$$ROOT^DILFD(MDNUM,,1)
+11 if $GET(MDFLDS)=""
SET MDFLDS="*"
+12 ;
+13 ; Load the records via Fileman GETS^DIQ
+14 ;
+15 SET MDIEN=0
+16 FOR
SET MDIEN=$ORDER(@MDROOT@(MDIEN))
if 'MDIEN
QUIT
Begin DoDot:1
+17 DO GETS^DIQ(MDNUM,MDIEN_",",MDFLDS,"I",MDTEMP)
End DoDot:1
+18 ;
+19 ; Grab the tags and types if any records were processed
+20 ;
+21 SET MDIEN=$ORDER(@MDTEMP@(MDNUM,""))
if MDIEN]""
Begin DoDot:1
+22 FOR X=0:0
SET X=$ORDER(@MDTEMP@(MDNUM,MDIEN,X))
if 'X
QUIT
Begin DoDot:2
+23 SET MDTAG=$$GET1^DID(MDNUM,X,,"LABEL")
+24 SET MDTYPE=$$GET1^DID(MDNUM,X,,"TYPE")
+25 SET MDPTR=$$GET1^DID(MDNUM,X,,"POINTER")
+26 SET @MDTEMP@(MDNUM,0,X,"TAG")=$$TAGSAFE(MDTAG)
+27 SET @MDTEMP@(MDNUM,0,X,"TYPE")=MDTYPE
+28 SET @MDTEMP@(MDNUM,0,X,"PTR")=MDPTR
End DoDot:2
End DoDot:1
+29 ;
+30 ; Ok, lets add the file
+31 ;
+32 DO XMLDATA("TABLENAME",MDNAME)
+33 SET MDIENS=$ORDER(@MDTEMP@(MDNUM,0))
+34 FOR
if MDIENS=""
QUIT
Begin DoDot:1
+35 DO XMLHDR("RECORD")
+36 SET MDFLD=$ORDER(@MDTEMP@(MDNUM,MDIENS,0))
+37 FOR
if MDFLD=""
QUIT
Begin DoDot:2
+38 SET MDTAG=@MDTEMP@(MDNUM,0,MDFLD,"TAG")
+39 SET MDATA=@MDTEMP@(MDNUM,MDIENS,MDFLD,"I")
+40 SET MDTYPE=@MDTEMP@(MDNUM,0,MDFLD,"TYPE")
Begin DoDot:3
+41 IF MDTYPE["WORD"
DO XMLWP(MDTAG,MDATA)
QUIT
+42 IF MDTYPE["DATE"
DO XMLDT(MDTAG,MDATA)
QUIT
+43 DO XMLDATA(MDTAG,MDATA)
End DoDot:3
+44 SET MDFLD=$ORDER(@MDTEMP@(MDNUM,MDIENS,MDFLD))
End DoDot:2
+45 DO XMLFTR("RECORD")
+46 SET MDIENS=$ORDER(@MDTEMP@(MDNUM,MDIENS))
End DoDot:1
+47 QUIT
+48 ;
BLDFLD(RESULTS,DD,FLDS) ; Add a field or field^field to the FLDS array
+1 FOR
Begin DoDot:1
+2 SET Y=$PIECE(FLDS,"^",1)
SET FLDS=$PIECE(FLDS,"^",2,250)
+3 SET MDFLD=$PIECE(Y,";",1)
KILL RESULTS(MDFLD)
+4 IF $PIECE(Y,";",2)]""
SET RESULTS(MDFLD,"FORMAT")=$PIECE(Y,";",2)
+5 IF '$TEST
SET RESULTS(MDFLD,"FORMAT")="I"
+6 IF $PIECE(Y,";",3)]""
SET RESULTS(MDFLD,"TAG")=$PIECE(Y,";",3)
+7 IF '$TEST
SET RESULTS(MDFLD,"TAG")=$TRANSLATE($$GET1^DID(DD,MDFLD,"","LABEL")," ","_")
+8 IF $PIECE(Y,";",4)]""
SET RESULTS(MDFLD,"TYPE")=$PIECE(Y,";",4)
+9 IF '$TEST
SET RESULTS(MDFLD,"TYPE")=$$GET1^DID(DD,+MDFLD,"","TYPE")
End DoDot:1
if FLDS']""
QUIT
+10 QUIT
+11 ;
BLDXML(DD,IEN,FLDS) ; Builds an XML Record based on DD, IEN, and FLDS
+1 ; Note: this is a standalone module requiring DD and IEN
+2 ; so that it can be easily used by the custom query routines
+3 NEW MDFLD,MDIENS,X,Y
+4 DO XMLHDR("RECORD")
+5 SET MDIENS=IEN_","
SET MDFLD=""
+6 FOR
SET MDFLD=$ORDER(FLDS(MDFLD))
if MDFLD=""
QUIT
Begin DoDot:1
+7 ; .001 is always the IEN *IF* it is included in the view
+8 IF +MDFLD=.001
DO XMLDATA(FLDS(MDFLD,"TAG"),+MDIENS)
QUIT
+9 SET MDFMT=$GET(FLDS(MDFLD,"FORMAT"),"I")
+10 ; Process as a date
+11 IF $GET(FLDS(MDFLD,"TYPE"))["DATE"
Begin DoDot:2
+12 SET X=$$GET1^DIQ(DD,MDIENS,MDFLD,"I")
+13 IF X]""&(MDFMT'="I")
Begin DoDot:3
+14 SET Y=($EXTRACT(X,1,3)+1700)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)
if X'["."
QUIT
+15 ; Add it in ensure all the time parts
SET X=X+.0000001
+16 SET Y=Y_" "_$EXTRACT(X,9,10)_":"_$EXTRACT(X,11,12)_":"_$EXTRACT(X,13,14)
End DoDot:3
SET X=Y
+17 DO XMLDATA(FLDS(MDFLD,"TAG"),X)
End DoDot:2
QUIT
+18 ; Process as WP
+19 IF $GET(FLDS(MDFLD,"TYPE"))["WORD"
Begin DoDot:2
+20 DO XMLHDR(FLDS(MDFLD,"TAG"))
+21 SET Y=$ORDER(@RESULTS@(""),-1)+1
+22 SET X=$$GET1^DIQ(DD,MDIENS,MDFLD,"",$NAME(@RESULTS@(Y)))
+23 DO XMLFTR(FLDS(MDFLD,"TAG"))
End DoDot:2
QUIT
+24 ; Just return with specified data format
+25 IF ($GET(FLDS(MDFLD,"TYPE"))["SET")&(DD=704.202)&(MDFLD=.09)
Begin DoDot:2
+26 IF $$GET1^DIQ(DD,MDIENS,MDFLD,MDFMT)["DISABLED"
DO XMLDATA(FLDS(MDFLD,"TAG"),$$GET1^DIQ(DD,MDIENS,MDFLD,MDFMT))
QUIT
+27 LOCK +^MDK(704.202,+MDIENS):1
+28 IF '$TEST
DO XMLDATA(FLDS(MDFLD,"TAG"),"IN_USE")
QUIT
+29 IF '$TEST
LOCK -^MDK(704.202,+MDIENS)
DO XMLDATA(FLDS(MDFLD,"TAG"),$$GET1^DIQ(DD,MDIENS,MDFLD,MDFMT))
+30 QUIT
End DoDot:2
QUIT
+31 DO XMLDATA(FLDS(MDFLD,"TAG"),$$GET1^DIQ(DD,MDIENS,MDFLD,MDFMT))
End DoDot:1
+32 DO XMLFTR("RECORD")
+33 QUIT
+34 ;
XMLCMT(COMMENT) ; Add a comment to a document
+1 DO XMLADD("<!-- "_COMMENT_" -->")
+2 QUIT
+3 ;
XMLHDR(TAG) ; Add a header tag to the global
+1 SET TAG=$$TAGSAFE(TAG)
+2 DO XMLADD("<"_TAG_">")
+3 QUIT
+4 ;
XMLFTR(TAG) ; Add a footer tag to the global
+1 DO XMLHDR("/"_TAG)
+2 QUIT
+3 ;
XMLDATA(TAG,X) ; Add a data element to the global
+1 SET TAG=$$TAGSAFE(TAG)
+2 IF $GET(X)=""
DO XMLADD("<"_TAG_" />")
+3 IF '$TEST
DO XMLADD("<"_TAG_">"_$$XMLSAFE(X)_"</"_TAG_">")
+4 QUIT
+5 ;
XMLPT(X) ; Add a standard pt identifier node
+1 SET X(1,"NAME")=$PIECE(^DPT(X,0),U)
+2 SET X(2,"SSN")=$PIECE(^DPT(X,0),U,9)
+3 SET X(3,"SEX")=$PIECE(^DPT(X,0),U,2)
+4 SET Y=$PIECE(^DPT(X,0),U,3)
+5 SET Y(1)=1700+$EXTRACT(Y,1,3)
SET Y(2)=+$EXTRACT(Y,4,5)
SET Y(3)=+$EXTRACT(Y,6,7)
+6 SET X(4,"DOB_Y")=Y(1)
+7 SET X(5,"DOB_M")=Y(2)
+8 SET X(6,"DOB_D")=Y(3)
+9 DO XMLIDS("PATIENT",.X,1)
+10 QUIT
+11 ;
XMLWP(TAG,X) ; Add text in array @X to the global
+1 SET TAG=$$TAGSAFE(TAG)
+2 ; Empty global ref
IF $GET(X)=""
DO XMLADD("<"_TAG_" />")
QUIT
+3 DO XMLHDR(TAG)
+4 FOR Y=0:0
SET Y=$ORDER(@X@(Y))
if 'Y
QUIT
DO XMLADD(@X@(Y))
+5 DO XMLFTR(TAG)
+6 QUIT
+7 ;
XMLDT(TAG,X) ; Add date or date/time to the global
+1 SET TAG=$$TAGSAFE(TAG)
+2 ; No data
IF $GET(X)=""
DO XMLADD("<"_TAG_" />")
QUIT
+3 ; Build the ID array
+4 SET X(1,"Y")=(1700+$EXTRACT(X,1,3))
+5 SET X(2,"M")=+$EXTRACT(X,4,5)
+6 SET X(3,"D")=+$EXTRACT(X,6,7)
+7 if X]"."
Begin DoDot:1
+8 SET X=X+.0000001
+9 SET X(4,"hh")=+$EXTRACT(X,9,10)
+10 SET X(5,"mm")=+$EXTRACT(X,11,12)
+11 SET X(6,"ss")=+$EXTRACT(X,13,14)
End DoDot:1
+12 DO XMLIDS(TAG,.X,1)
+13 QUIT
+14 ;
XMLIDS(TAG,IDS,CLOSE) ; Add a data element to the global with ids
+1 SET TAG="<"_$$TAGSAFE(TAG)
+2 FOR X=0:0
SET X=$ORDER(IDS(X))
if 'X
QUIT
Begin DoDot:1
+3 SET Y=""
FOR
SET Y=$ORDER(IDS(X,Y))
if Y=""
QUIT
Begin DoDot:2
+4 SET TAG=TAG_" "_Y_"="""_$$XMLSAFE(IDS(X,Y))_""""
End DoDot:2
End DoDot:1
+5 ; Close out the tag element
if $GET(CLOSE)
SET TAG=TAG_" /"
+6 SET TAG=TAG_">"
+7 DO XMLADD(TAG)
+8 QUIT
+9 ;
XMLADD(X) ; Add to the global
+1 SET @RESULTS@($ORDER(@RESULTS@(""),-1)+1)=$GET(X)
+2 QUIT
+3 ;
ADDERR(X) ;
+1 SET MDERROR($ORDER(MDERR(""),-1)+1)=X
+2 QUIT
+3 ;
XMLOK(RESULTS) ; Build an XML OK message
+1 KILL @RESULTS
+2 SET @RESULTS@(0)="<RESULTS>"
+3 SET @RESULTS@(1)="<STATUS>OK</STATUS>"
+4 SET @RESULTS@(2)="</RESULTS>"
+5 QUIT
+6 ;
XMLERR(ERRMSG) ; Build an XML error Message to return
+1 KILL @RESULTS
+2 SET @RESULTS@(0)="<RESULTS>"
+3 SET @RESULTS@(1)="<STATUS>ERROR</STATUS>"
+4 ; Simple one liner
IF $DATA(ERRMSG)=1
Begin DoDot:1
+5 SET @RESULTS@(2)="<MESSAGE>"_$$XMLSAFE(ERRMSG)_"</MESSAGE>"
End DoDot:1
+6 ; Load the array into the XML message
IF $DATA(ERRMSG)>2
Begin DoDot:1
+7 SET @RESULTS@(2)="<MESSAGE>"_$GET(ERRMSG,"NO DESCRIPTION")
+8 SET X="ERRMSG"
FOR
SET X=$QUERY(@X)
if X=""!(X'?1"ERRMSG(".E)
QUIT
Begin DoDot:2
+9 SET @RESULTS@($ORDER(@RESULTS@(""),-1)+1)=$$XMLSAFE(@X)
End DoDot:2
+10 SET @RESULTS@($ORDER(@RESULTS@(""),-1)+1)="</MESSAGE>"
End DoDot:1
+11 SET @RESULTS@($ORDER(@RESULTS@(""),-1)+1)="</RESULTS>"
+12 QUIT
+13 ;
XMLDATE(X) ; Transform Y into XML safe date
+1 NEW Y
+2 SET Y=($EXTRACT(X,1,3)+1700)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)
+3 if X["."
Begin DoDot:1
+4 SET X=X+.0000001
+5 SET Y=Y_" "_$EXTRACT(X,9,10)_":"_$EXTRACT(X,11,12)_":"_$EXTRACT(X,13,14)
End DoDot:1
+6 QUIT Y
+7 ;
XMLSAFE(X) ; Transform X into XML safe data
+1 SET X=$$TRNSLT(X,"&","&")
+2 SET X=$$TRNSLT(X,"<","<")
+3 SET X=$$TRNSLT(X,">",">")
+4 SET X=$$TRNSLT(X,"'","'")
+5 SET X=$$TRNSLT(X,"""",""")
+6 QUIT X
+7 ;
TAGSAFE(X) ; Transform X into XML tag
+1 ; Remove starting numeric
if X?1N.E
SET X="_"_X
+2 QUIT $TRANSLATE(X," '`()<>*[]","__________")
+3 ;
NEWDOC(ROOT,COMMENT) ; Start a new document
+1 KILL @RESULTS
+2 DO XMLADD("<?xml version=""1.0"" standalone=""yes""?>")
+3 IF $GET(COMMENT)]""
DO XMLCMT(COMMENT)
+4 DO XMLHDR($GET(ROOT,"RESULTS"))
+5 QUIT
+6 ;
ENDDOC(ROOT) ; End this document
+1 DO XMLFTR($GET(ROOT,"RESULTS"))
+2 QUIT
+3 ;
TRNSLT(X,X1,X2) ; Translate every Y to Z in X
+1 NEW Y
+2 ; Nothing to translate
if X'[X1
QUIT X
+3 SET Y=""
FOR
if X=""
QUIT
Begin DoDot:1
+4 IF X[X1
SET Y=Y_$PIECE(X,X1)_X2
SET X=$PIECE(X,X1,2,250)
QUIT
+5 SET Y=Y_X
SET X=""
End DoDot:1
+6 QUIT Y
+7 ;
