source: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDXMLFM1.m@ 628

MDXMLFM1 ; HOIFO/DP/NCA - Data -> 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  S MDFDAT=$G(@IENLIST@(MDIEN)) D
 .D BLDXML(DD,MDIEN,.FLDS,MDFDAT)
 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,MDFDAT) ; 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,MDKTR,X,Y
 D XMLHDR("RECORD")
 S MDIENS=IEN_",",MDFLD="",MDKTR=0
 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) S MDKTR=MDKTR+1 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
 .S MDKTR=MDKTR+1
 .D XMLDATA(FLDS(MDFLD,"TAG"),$P(MDFDAT,U,MDKTR))
 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,"&","&amp;")
 S X=$$TRNSLT(X,"<","&lt;")
 S X=$$TRNSLT(X,">","&gt;")
 S X=$$TRNSLT(X,"'","&apos;")
 S X=$$TRNSLT(X,"""","&quot;")
 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
 ;