Routine: PSOERXOC

PSOERXOC ;ALB/BWF - eRx parsing Utilities ; 11/14/2019 3:46pm

 ;;7.0;OUTPATIENT PHARMACY;**581**;DEC 1997;Build 126

PATIENT(GBL,CNT,PSOSITE,IEN) ;

 N F,PATREL,LNAME,FNAME,MNAME,SUFF,PREF,GENDER,DOB,ADDL1,ADDL2,CITY,STATE,ZIP,PLQ,CUNIT,BED,ROOM,PSDAT,ILOOP

 N ITYP,IVAL,CLOOP,CNUM,CQUAL,PIEN,PIENS,PSSN,LANGNC,GESTAGE,HOSPIND,ACLN,ACFN,ACMN,ACSUFF,ACPREF,ACRELAT,ACFLN

 N ACFFN,ACFMN,ACFSUFF,ACFPREF,ACADL1,ACADL2,ACCITY,ACSTATE,ACPOSTAL,ACCC,DIRADD,ALDIRADD,MEDICARE,MEDICAID,MEDICAL,ACCNUM,MUTDEF,REMS

 N ASGBL,CC,FOFN,FOLN,FOMN,FOPREF,FOSUFF,SGBL

 S F=52.46

 S PIEN=$$GET1^DIQ(52.49,IEN,.04,"I") Q:'PIEN

 S PIENS=PIEN_","

 D GETS^DIQ(F,PIENS,"**","IE","PSDAT")

 D CONVXML^PSOERXX1("PSDAT")

 S PATREL=$G(PSDAT(F,PIENS,1.7,"I"))

 S LNAME=$G(PSDAT(F,PIENS,.02,"E"))

 S FNAME=$G(PSDAT(F,PIENS,.03,"E"))

 S MNAME=$G(PSDAT(F,PIENS,.04,"E"))

 S SUFF=$G(PSDAT(F,PIENS,.05,"E"))

 S PREF=$G(PSDAT(F,PIENS,.06,"E"))

 S GENDER=$G(PSDAT(F,PIENS,.07,"I"))

 S DOB=$G(PSDAT(F,PIENS,.08,"I")) I $G(DOB) S DOB=$P($$EXTIME^PSOERXO1(DOB),"T")

 S ADDL1=$G(PSDAT(F,PIENS,3.1,"E"))

 S ADDL2=$G(PSDAT(F,PIENS,3.2,"E"))

 S CITY=$G(PSDAT(F,PIENS,3.3,"E"))

 S STATE=$G(PSDAT(F,PIENS,3.4,"I"))

 S ZIP=$G(PSDAT(F,PIENS,3.5,"E"))

 S CC=$G(PSDAT(F,PIENS,1.6,"E"))

 S PSSN=$G(PSDAT(F,PIENS,18.2,"E"))

 ; FUTURE ENHANCEMENT, GRAB CUNIT/BED/ROOM FROM CORRECT LOCATIONS. THIS LOGIC IS NOT ACTIVE WITH VERSION 2

 S CUNIT=$G(PSDAT(F,PIENS,8.1,"E")) ; 8.1

 S BED=$G(PSDAT(F,PIENS,8.2,"E")) ; 8.3

 S ROOM=$G(PSDAT(F,PIENS,8.3,"E")) ; 8.2

 ;start grabbing 2017 variables

 S FOLN=$G(PSDAT(F,PIENS,7.1,"E"))

 S FOFN=$G(PSDAT(F,PIENS,7.2,"E"))

 S FOMN=$G(PSDAT(F,PIENS,7.3,"E"))

 S FOSUFF=$G(PSDAT(F,PIENS,7.4,"E"))

 S FOPREF=$G(PSDAT(F,PIENS,7.5,"E"))

 S LANGNC=$G(PSDAT(F,PIENS,8.4,"E"))

 S GESTAGE=$G(PSDAT(F,PIENS,8.5,"E"))

 S HOSPIND=$G(PSDAT(F,PIENS,8.6,"I"))

 S ACLN=$G(PSDAT(F,PIENS,9.1,"E"))

 S ACFN=$G(PSDAT(F,PIENS,9.2,"E"))

 S ACMN=$G(PSDAT(F,PIENS,9.3,"E"))

 S ACSUFF=$G(PSDAT(F,PIENS,9.4,"E"))

 S ACPREF=$G(PSDAT(F,PIENS,9.5,"E"))

 S ACRELAT=$G(PSDAT(F,PIENS,9.6,"I")),ACRELAT=$$GET1^DIQ(52.45,ACRELAT,.01,"E")

 S ACFLN=$G(PSDAT(F,PIENS,10.1,"E"))

 S ACFFN=$G(PSDAT(F,PIENS,10.2,"E"))

 S ACFMN=$G(PSDAT(F,PIENS,10.3,"E"))

 S ACFSUFF=$G(PSDAT(F,PIENS,10.4,"E"))

 S ACFPREF=$G(PSDAT(F,PIENS,10.5,"E"))

 S ACADL1=$G(PSDAT(F,PIENS,11.1,"E"))

 S ACADL2=$G(PSDAT(F,PIENS,11.2,"E"))

 S ACCITY=$G(PSDAT(F,PIENS,11.3,"E"))

 S ACSTATE=$G(PSDAT(F,PIENS,11.4,"I"))

 S ACPOSTAL=$G(PSDAT(F,PIENS,11.5,"E"))

 S ACCC=$G(PSDAT(F,PIENS,11.6,"E"))

 ;alternate communication

 S ASGBL=$NA(^PS(52.46,IEN,15))

 S ALDIRADD=$G(PSDAT(F,PIENS,16,"E"))

 S MEDICARE=$G(PSDAT(F,PIENS,17.1,"E"))

 S MEDICAID=$G(PSDAT(F,PIENS,17.2,"E"))

 S MEDICAL=$G(PSDAT(F,PIENS,17.3,"E"))

 S ACCNUM=$G(PSDAT(F,PIENS,18.1,"E"))

 S MUTDEF=$G(PSDAT(F,PIENS,18.3,"E"))

 S REMS=$G(PSDAT(F,PIENS,18.4,"E"))

 ;end 2017 variables

 ;new outbound building - 12/9/19

 D C S @GBL@(CNT,0)="<Patient>"

 D C S @GBL@(CNT,0)="<HumanPatient>"

 I $L(MEDICARE_MEDICAID_MEDICAL_ACCNUM_PSSN_MUTDEF_REMS) D

 .D C S @GBL@(CNT,0)="<Identification>"

 .D BL(GBL,.CNT,"MedicareNumber",MEDICARE)

 .D BL(GBL,.CNT,"MedicaidNumber",MEDICAID)

 .D BL(GBL,.CNT,"MedicalRecordIdentificationNumberEHR",MEDICAL)

 .D BL(GBL,.CNT,"PatientAccountNumber",ACCNUM)

 .D BL(GBL,.CNT,"SocialSecurity",PSSN)

 .D BL(GBL,.CNT,"MutuallyDefined",MUTDEF)

 .D BL(GBL,.CNT,"REMSPatientID",REMS)

 .D C S @GBL@(CNT,0)="</Identification>"

 D ONAME^PSOERXOU(GBL,.CNT,"Name",LNAME,FNAME,MNAME,SUFF,PREF)

 I $L(FOLN) D

 .D ONAME^PSOERXOU(GBL,.CNT,"FormerName",FOLN,FOFN,FOMN,FOSUFF,FOPREF)

 D BL(GBL,.CNT,"Gender",GENDER)

 D C S @GBL@(CNT,0)="<DateOfBirth>"

 D BL(GBL,.CNT,"Date",DOB)

 D C S @GBL@(CNT,0)="</DateOfBirth>"

 D OADD^PSOERXOU(GBL,.CNT,ADDL1,ADDL2,CITY,STATE,ZIP,CC)

 S SGBL=$NA(^PS(52.46,PIEN,13))

 D OCOMM^PSOERXOU(GBL,SGBL,.CNT,PIEN_",",52.4613,52.46,14,PIEN_",")

 I $L(CUNIT_BED_ROOM) D

 .D C S @GBL@(CNT,0)="<PatientLocation>"

 .D BL(GBL,.CNT,"FacilityUnit",CUNIT)

 .D BL(GBL,.CNT,"BED",BED)

 .D BL(GBL,.CNT,"Room",ROOM)

 .D C S @GBL@(CNT,0)="</PatientLocation>"

 .D BL(GBL,.CNT,"LanguageNameCode",LANGNC)

 D SUBSTNCE(PIEN,52.4619,GBL)

 I $L(ACLN) D

 .D C S @GBL@(CNT,0)="<AlternateContact>"

 .D ONAME^PSOERXOU(GBL,.CNT,"Name",ACLN,ACFN,ACMN,ACSUFF,ACPREF)

 .I $L(ACFLN) D

 ..D ONAME^PSOERXOU(GBL,.CNT,"FormerName",ACFLN,ACFFN,ACFMN,ACFPREF,ACFSUFF)

 .D OADD^PSOERXOU(GBL,.CNT,ACADL1,ACADL2,ACCITY,ACSTATE,ACPOSTAL,ACCC)

 .S SGBL=$NA(^PS(52.46,PIEN,15))

 .D OCOMM^PSOERXOU(GBL,SGBL,.CNT,PIEN_",",52.4615,52.46,16,PIEN_",")

 .D BL(GBL,.CNT,"AlternateContactRelationship",ACRELAT)

 .D C S @GBL@(CNT,0)="</AlternateContact>"

 .D BL(GBL,.CNT,"GestationalAge",GESTAGE)

 .D BL(GBL,.CNT,"HospiceIndicator",HOSPIND)

 ;end new outbound building

 D C S @GBL@(CNT,0)="</HumanPatient>"

 D C S @GBL@(CNT,0)="</Patient>"

SUBSTNCE(PIEN,SFILE,GBL) ; patient substance (52.4619)

 N SFIEN,SUBIENS,TYPETEXT,TYPEQUAL,TYPECODE,LEVTEXT

 N LEVQUAL,LEVCODE,ROATEXT,ROAQUAL,ROACODE,SUBDAT

 S SFIEN=0,IEN=5531,SFILE=52.4619

 Q:'$O(^PS(52.46,PIEN,19,0))

 F  S SFIEN=$O(^PS(52.46,PIEN,19,SFIEN)) Q:'SFIEN  D

 .S SUBIENS=SFIEN_","_PIEN_","

 .D GETS^DIQ(52.4619,SUBIENS,"**","E","SUBDAT")

 .S TYPETEXT=$G(SUBDAT(SFILE,SUBIENS,1,"E"))

 .S TYPEQUAL=$G(SUBDAT(SFILE,SUBIENS,2,"E"))

 .S TYPECODE=$G(SUBDAT(SFILE,SUBIENS,3,"E"))

 .S LEVTEXT=$G(SUBDAT(SFILE,SUBIENS,4,"E"))

 .S LEVQUAL=$G(SUBDAT(SFILE,SUBIENS,5,"E"))

 .S LEVCODE=$G(SUBDAT(SFILE,SUBIENS,6,"E"))

 .S ROATEXT=$G(SUBDAT(SFILE,SUBIENS,7,"E"))

 .S ROAQUAL=$G(SUBDAT(SFILE,SUBIENS,8,"E"))

 .S ROACODE=$G(SUBDAT(SFILE,SUBIENS,9,"E"))

 .I $L(TYPETEXT_TYPEQUAL_TYPECODE_LEVTEXT_LEVQUAL_LEVCODE_ROATEXT_ROAQUAL_ROACODE) D

 ..D C S @GBL@(CNT,0)="<SubstanceUse>"

 ..D C S @GBL@(CNT,0)="<Substance>"

 ..D C S @GBL@(CNT,0)="<Type>"

 ..D BL(GBL,.CNT,"Text",TYPETEXT)

 ..D BL(GBL,.CNT,"Qualifier",TYPEQUAL)

 ..D BL(GBL,.CNT,"Code",TYPECODE)

 ..D C S @GBL@(CNT,0)="</Type>"

 ..I $L(LEVTEXT_LEVQUAL_LEVCODE) D

 ...D C S @GBL@(CNT,0)="<Level>"

 ...D BL(GBL,.CNT,"Text",LEVTEXT)

 ...D BL(GBL,.CNT,"Qualifier",LEVQUAL)

 ...D BL(GBL,.CNT,"Code",LEVCODE)

 ...D C S @GBL@(CNT,0)="</Level>"

 ..I $L(ROATEXT_ROAQUAL_ROACODE) D

 ...D C S @GBL@(CNT,0)="<RouteOfAdministration>"

 ...D BL(GBL,.CNT,"Text",ROATEXT)

 ...D BL(GBL,.CNT,"Qualifier",ROAQUAL)

 ...D BL(GBL,.CNT,"Code",ROACODE)

 ...D C S @GBL@(CNT,0)="</RouteOfAdministration>"

 ..D C S @GBL@(CNT,0)="</Substance>"

 ..D C S @GBL@(CNT,0)="</SubstanceUse>"

BL(GBL,CNT,TAG,VAR) ;

 Q:VAR=""

 D C S @GBL@(CNT,0)="<"_TAG_">"_$$SYMENC^MXMLUTL(VAR)_"</"_TAG_">"

C ;

 S CNT=$G(CNT)+1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXOC   6717     printed  Feb 18, 2025@23:55:14                                                                                                                                                                                                    Page 2

PSOERXOC  ;ALB/BWF - eRx parsing Utilities ; 11/14/2019 3:46pm

 +1       ;;7.0;OUTPATIENT PHARMACY;**581**;DEC 1997;Build 126

 +2       ;

 +3        QUIT

PATIENT(GBL,CNT,PSOSITE,IEN) ;

 +1        NEW F,PATREL,LNAME,FNAME,MNAME,SUFF,PREF,GENDER,DOB,ADDL1,ADDL2,CITY,STATE,ZIP,PLQ,CUNIT,BED,ROOM,PSDAT,ILOOP

 +2        NEW ITYP,IVAL,CLOOP,CNUM,CQUAL,PIEN,PIENS,PSSN,LANGNC,GESTAGE,HOSPIND,ACLN,ACFN,ACMN,ACSUFF,ACPREF,ACRELAT,ACFLN

 +3        NEW ACFFN,ACFMN,ACFSUFF,ACFPREF,ACADL1,ACADL2,ACCITY,ACSTATE,ACPOSTAL,ACCC,DIRADD,ALDIRADD,MEDICARE,MEDICAID,MEDICAL,ACCNUM,MUTDEF,REMS

 +4        NEW ASGBL,CC,FOFN,FOLN,FOMN,FOPREF,FOSUFF,SGBL

 +5        SET F=52.46

 +6        SET PIEN=$$GET1^DIQ(52.49,IEN,.04,"I")

           if 'PIEN

               QUIT

 +7        SET PIENS=PIEN_","

 +8        DO GETS^DIQ(F,PIENS,"**","IE","PSDAT")

 +9        DO CONVXML^PSOERXX1("PSDAT")

 +10       SET PATREL=$GET(PSDAT(F,PIENS,1.7,"I"))

 +11       SET LNAME=$GET(PSDAT(F,PIENS,.02,"E"))

 +12       SET FNAME=$GET(PSDAT(F,PIENS,.03,"E"))

 +13       SET MNAME=$GET(PSDAT(F,PIENS,.04,"E"))

 +14       SET SUFF=$GET(PSDAT(F,PIENS,.05,"E"))

 +15       SET PREF=$GET(PSDAT(F,PIENS,.06,"E"))

 +16       SET GENDER=$GET(PSDAT(F,PIENS,.07,"I"))

 +17       SET DOB=$GET(PSDAT(F,PIENS,.08,"I"))

           IF $GET(DOB)

               SET DOB=$PIECE($$EXTIME^PSOERXO1(DOB),"T")

 +18       SET ADDL1=$GET(PSDAT(F,PIENS,3.1,"E"))

 +19       SET ADDL2=$GET(PSDAT(F,PIENS,3.2,"E"))

 +20       SET CITY=$GET(PSDAT(F,PIENS,3.3,"E"))

 +21       SET STATE=$GET(PSDAT(F,PIENS,3.4,"I"))

 +22       SET ZIP=$GET(PSDAT(F,PIENS,3.5,"E"))

 +23       SET CC=$GET(PSDAT(F,PIENS,1.6,"E"))

 +24       SET PSSN=$GET(PSDAT(F,PIENS,18.2,"E"))

 +25      ; FUTURE ENHANCEMENT, GRAB CUNIT/BED/ROOM FROM CORRECT LOCATIONS. THIS LOGIC IS NOT ACTIVE WITH VERSION 2

 +26      ; 8.1

           SET CUNIT=$GET(PSDAT(F,PIENS,8.1,"E"))

 +27      ; 8.3

           SET BED=$GET(PSDAT(F,PIENS,8.2,"E"))

 +28      ; 8.2

           SET ROOM=$GET(PSDAT(F,PIENS,8.3,"E"))

 +29      ;

 +30      ;start grabbing 2017 variables

 +31      ;

 +32       SET FOLN=$GET(PSDAT(F,PIENS,7.1,"E"))

 +33       SET FOFN=$GET(PSDAT(F,PIENS,7.2,"E"))

 +34       SET FOMN=$GET(PSDAT(F,PIENS,7.3,"E"))

 +35       SET FOSUFF=$GET(PSDAT(F,PIENS,7.4,"E"))

 +36       SET FOPREF=$GET(PSDAT(F,PIENS,7.5,"E"))

 +37       SET LANGNC=$GET(PSDAT(F,PIENS,8.4,"E"))

 +38       SET GESTAGE=$GET(PSDAT(F,PIENS,8.5,"E"))

 +39       SET HOSPIND=$GET(PSDAT(F,PIENS,8.6,"I"))

 +40       SET ACLN=$GET(PSDAT(F,PIENS,9.1,"E"))

 +41       SET ACFN=$GET(PSDAT(F,PIENS,9.2,"E"))

 +42       SET ACMN=$GET(PSDAT(F,PIENS,9.3,"E"))

 +43       SET ACSUFF=$GET(PSDAT(F,PIENS,9.4,"E"))

 +44       SET ACPREF=$GET(PSDAT(F,PIENS,9.5,"E"))

 +45       SET ACRELAT=$GET(PSDAT(F,PIENS,9.6,"I"))

           SET ACRELAT=$$GET1^DIQ(52.45,ACRELAT,.01,"E")

 +46       SET ACFLN=$GET(PSDAT(F,PIENS,10.1,"E"))

 +47       SET ACFFN=$GET(PSDAT(F,PIENS,10.2,"E"))

 +48       SET ACFMN=$GET(PSDAT(F,PIENS,10.3,"E"))

 +49       SET ACFSUFF=$GET(PSDAT(F,PIENS,10.4,"E"))

 +50       SET ACFPREF=$GET(PSDAT(F,PIENS,10.5,"E"))

 +51       SET ACADL1=$GET(PSDAT(F,PIENS,11.1,"E"))

 +52       SET ACADL2=$GET(PSDAT(F,PIENS,11.2,"E"))

 +53       SET ACCITY=$GET(PSDAT(F,PIENS,11.3,"E"))

 +54       SET ACSTATE=$GET(PSDAT(F,PIENS,11.4,"I"))

 +55       SET ACPOSTAL=$GET(PSDAT(F,PIENS,11.5,"E"))

 +56       SET ACCC=$GET(PSDAT(F,PIENS,11.6,"E"))

 +57      ;alternate communication

 +58       SET ASGBL=$NAME(^PS(52.46,IEN,15))

 +59       SET ALDIRADD=$GET(PSDAT(F,PIENS,16,"E"))

 +60       SET MEDICARE=$GET(PSDAT(F,PIENS,17.1,"E"))

 +61       SET MEDICAID=$GET(PSDAT(F,PIENS,17.2,"E"))

 +62       SET MEDICAL=$GET(PSDAT(F,PIENS,17.3,"E"))

 +63       SET ACCNUM=$GET(PSDAT(F,PIENS,18.1,"E"))

 +64       SET MUTDEF=$GET(PSDAT(F,PIENS,18.3,"E"))

 +65       SET REMS=$GET(PSDAT(F,PIENS,18.4,"E"))

 +66      ;end 2017 variables

 +67      ;

 +68      ;new outbound building - 12/9/19

 +69      ;

 +70       DO C

           SET @GBL@(CNT,0)="<Patient>"

 +71       DO C

           SET @GBL@(CNT,0)="<HumanPatient>"

 +72       IF $LENGTH(MEDICARE_MEDICAID_MEDICAL_ACCNUM_PSSN_MUTDEF_REMS)

               Begin DoDot:1

 +73               DO C

                   SET @GBL@(CNT,0)="<Identification>"

 +74               DO BL(GBL,.CNT,"MedicareNumber",MEDICARE)

 +75               DO BL(GBL,.CNT,"MedicaidNumber",MEDICAID)

 +76               DO BL(GBL,.CNT,"MedicalRecordIdentificationNumberEHR",MEDICAL)

 +77               DO BL(GBL,.CNT,"PatientAccountNumber",ACCNUM)

 +78               DO BL(GBL,.CNT,"SocialSecurity",PSSN)

 +79               DO BL(GBL,.CNT,"MutuallyDefined",MUTDEF)

 +80               DO BL(GBL,.CNT,"REMSPatientID",REMS)

 +81               DO C

                   SET @GBL@(CNT,0)="</Identification>"

               End DoDot:1

 +82       DO ONAME^PSOERXOU(GBL,.CNT,"Name",LNAME,FNAME,MNAME,SUFF,PREF)

 +83       IF $LENGTH(FOLN)

               Begin DoDot:1

 +84               DO ONAME^PSOERXOU(GBL,.CNT,"FormerName",FOLN,FOFN,FOMN,FOSUFF,FOPREF)

               End DoDot:1

 +85       DO BL(GBL,.CNT,"Gender",GENDER)

 +86       DO C

           SET @GBL@(CNT,0)="<DateOfBirth>"

 +87       DO BL(GBL,.CNT,"Date",DOB)

 +88       DO C

           SET @GBL@(CNT,0)="</DateOfBirth>"

 +89       DO OADD^PSOERXOU(GBL,.CNT,ADDL1,ADDL2,CITY,STATE,ZIP,CC)

 +90       SET SGBL=$NAME(^PS(52.46,PIEN,13))

 +91       DO OCOMM^PSOERXOU(GBL,SGBL,.CNT,PIEN_",",52.4613,52.46,14,PIEN_",")

 +92       IF $LENGTH(CUNIT_BED_ROOM)

               Begin DoDot:1

 +93               DO C

                   SET @GBL@(CNT,0)="<PatientLocation>"

 +94               DO BL(GBL,.CNT,"FacilityUnit",CUNIT)

 +95               DO BL(GBL,.CNT,"BED",BED)

 +96               DO BL(GBL,.CNT,"Room",ROOM)

 +97               DO C

                   SET @GBL@(CNT,0)="</PatientLocation>"

 +98               DO BL(GBL,.CNT,"LanguageNameCode",LANGNC)

               End DoDot:1

 +99       DO SUBSTNCE(PIEN,52.4619,GBL)

 +100      IF $LENGTH(ACLN)

               Begin DoDot:1

 +101              DO C

                   SET @GBL@(CNT,0)="<AlternateContact>"

 +102              DO ONAME^PSOERXOU(GBL,.CNT,"Name",ACLN,ACFN,ACMN,ACSUFF,ACPREF)

 +103              IF $LENGTH(ACFLN)

                       Begin DoDot:2

 +104                      DO ONAME^PSOERXOU(GBL,.CNT,"FormerName",ACFLN,ACFFN,ACFMN,ACFPREF,ACFSUFF)

                       End DoDot:2

 +105              DO OADD^PSOERXOU(GBL,.CNT,ACADL1,ACADL2,ACCITY,ACSTATE,ACPOSTAL,ACCC)

 +106              SET SGBL=$NAME(^PS(52.46,PIEN,15))

 +107              DO OCOMM^PSOERXOU(GBL,SGBL,.CNT,PIEN_",",52.4615,52.46,16,PIEN_",")

 +108              DO BL(GBL,.CNT,"AlternateContactRelationship",ACRELAT)

 +109              DO C

                   SET @GBL@(CNT,0)="</AlternateContact>"

 +110              DO BL(GBL,.CNT,"GestationalAge",GESTAGE)

 +111              DO BL(GBL,.CNT,"HospiceIndicator",HOSPIND)

               End DoDot:1

 +112     ;end new outbound building

 +113      DO C

           SET @GBL@(CNT,0)="</HumanPatient>"

 +114      DO C

           SET @GBL@(CNT,0)="</Patient>"

 +115      QUIT

SUBSTNCE(PIEN,SFILE,GBL) ; patient substance (52.4619)

 +1        NEW SFIEN,SUBIENS,TYPETEXT,TYPEQUAL,TYPECODE,LEVTEXT

 +2        NEW LEVQUAL,LEVCODE,ROATEXT,ROAQUAL,ROACODE,SUBDAT

 +3        SET SFIEN=0

           SET IEN=5531

           SET SFILE=52.4619

 +4        if '$ORDER(^PS(52.46,PIEN,19,0))

               QUIT

 +5        FOR

               SET SFIEN=$ORDER(^PS(52.46,PIEN,19,SFIEN))

               if 'SFIEN

                   QUIT

               Begin DoDot:1

 +6                SET SUBIENS=SFIEN_","_PIEN_","

 +7                DO GETS^DIQ(52.4619,SUBIENS,"**","E","SUBDAT")

 +8                SET TYPETEXT=$GET(SUBDAT(SFILE,SUBIENS,1,"E"))

 +9                SET TYPEQUAL=$GET(SUBDAT(SFILE,SUBIENS,2,"E"))

 +10               SET TYPECODE=$GET(SUBDAT(SFILE,SUBIENS,3,"E"))

 +11               SET LEVTEXT=$GET(SUBDAT(SFILE,SUBIENS,4,"E"))

 +12               SET LEVQUAL=$GET(SUBDAT(SFILE,SUBIENS,5,"E"))

 +13               SET LEVCODE=$GET(SUBDAT(SFILE,SUBIENS,6,"E"))

 +14               SET ROATEXT=$GET(SUBDAT(SFILE,SUBIENS,7,"E"))

 +15               SET ROAQUAL=$GET(SUBDAT(SFILE,SUBIENS,8,"E"))

 +16               SET ROACODE=$GET(SUBDAT(SFILE,SUBIENS,9,"E"))

 +17               IF $LENGTH(TYPETEXT_TYPEQUAL_TYPECODE_LEVTEXT_LEVQUAL_LEVCODE_ROATEXT_ROAQUAL_ROACODE)

                       Begin DoDot:2

 +18                       DO C

                           SET @GBL@(CNT,0)="<SubstanceUse>"

 +19                       DO C

                           SET @GBL@(CNT,0)="<Substance>"

 +20                       DO C

                           SET @GBL@(CNT,0)="<Type>"

 +21                       DO BL(GBL,.CNT,"Text",TYPETEXT)

 +22                       DO BL(GBL,.CNT,"Qualifier",TYPEQUAL)

 +23                       DO BL(GBL,.CNT,"Code",TYPECODE)

 +24                       DO C

                           SET @GBL@(CNT,0)="</Type>"

 +25                       IF $LENGTH(LEVTEXT_LEVQUAL_LEVCODE)

                               Begin DoDot:3

 +26                               DO C

                                   SET @GBL@(CNT,0)="<Level>"

 +27                               DO BL(GBL,.CNT,"Text",LEVTEXT)

 +28                               DO BL(GBL,.CNT,"Qualifier",LEVQUAL)

 +29                               DO BL(GBL,.CNT,"Code",LEVCODE)

 +30                               DO C

                                   SET @GBL@(CNT,0)="</Level>"

                               End DoDot:3

 +31                       IF $LENGTH(ROATEXT_ROAQUAL_ROACODE)

                               Begin DoDot:3

 +32                               DO C

                                   SET @GBL@(CNT,0)="<RouteOfAdministration>"

 +33                               DO BL(GBL,.CNT,"Text",ROATEXT)

 +34                               DO BL(GBL,.CNT,"Qualifier",ROAQUAL)

 +35                               DO BL(GBL,.CNT,"Code",ROACODE)

 +36                               DO C

                                   SET @GBL@(CNT,0)="</RouteOfAdministration>"

                               End DoDot:3

 +37                       DO C

                           SET @GBL@(CNT,0)="</Substance>"

 +38                       DO C

                           SET @GBL@(CNT,0)="</SubstanceUse>"

                       End DoDot:2

               End DoDot:1

 +39       QUIT

BL(GBL,CNT,TAG,VAR) ;

 +1        if VAR=""

               QUIT

 +2        DO C

           SET @GBL@(CNT,0)="<"_TAG_">"_$$SYMENC^MXMLUTL(VAR)_"</"_TAG_">"

 +3        QUIT

C         ;

 +1        SET CNT=$GET(CNT)+1

 +2        QUIT

PSOERXOC.m