PSOERXOB ;ALB/BWF - eRx parsing Utilities ; 11/14/2019 3:46pm
;;7.0;OUTPATIENT PHARMACY;**581,651**;DEC 1997;Build 30
;
Q
OBENEFIT(GBL,CNT,ERXIEN) ;outbound benefits coordination section
N F,BIEN,SGBL,BDAT,PAYERID,PROCID,NAIC,MUTDEF,PHID,IIN,PAYNAME,CHID,CHLN,CHFN,CHMN,CHSUFF
N GROUPID,PAYRCODE,PATRCODE,PERCODE,GNAME,ADL1,ADL2,CITY,STATE,HPID
N POSTAL,CC,PBMID,RPLN,RPFN,RPMN,RPSUFF,RPPREF,PAYTYPE,BIENS,CHPREF
S F=52.49304
I '$O(^PS(52.49,ERXIEN,304,0)) Q
S BIEN=0 F S BIEN=$O(^PS(52.49,ERXIEN,304,BIEN)) Q:'BIEN D
.K BDAT
.S BIENS=BIEN_","_ERXIEN_","
.D GETS^DIQ(F,BIENS,"**","IE","BDAT")
.S PAYERID=$G(BDAT(F,BIENS,.02,"E"))
.S PROCID=$G(BDAT(F,BIENS,.03,"E"))
.S NAIC=$G(BDAT(F,BIENS,.04,"E"))
.S MUTDEF=$G(BDAT(F,BIENS,1.1,"E"))
.S HPID=$G(BDAT(F,BIENS,1.2,"E"))
.S IIN=$G(BDAT(F,BIENS,1.3,"E"))
.S PAYNAME=$G(BDAT(F,BIENS,2.1,"E"))
.S CHID=$G(BDAT(F,BIENS,2.2,"E"))
.S CHLN=$G(BDAT(F,BIENS,3.1,"E"))
.S CHFN=$G(BDAT(F,BIENS,3.2,"E"))
.S CHMN=$G(BDAT(F,BIENS,3.3,"E"))
.S CHSUFF=$G(BDAT(F,BIENS,3.4,"E"))
.S CHPREF=$G(BDAT(F,BIENS,3.5,"E"))
.S GROUPID=$G(BDAT(F,BIENS,4.1,"E"))
.S PAYRCODE=$G(BDAT(F,BIENS,4.3,"I"))
.S PATRCODE=$G(BDAT(F,BIENS,4.4,"I"))
.S PERCODE=$G(BDAT(F,BIENS,4.5,"E"))
.S GNAME=$G(BDAT(F,BIENS,4.6,"E"))
.S ADL1=$G(BDAT(F,BIENS,5.1,"E"))
.S ADL2=$G(BDAT(F,BIENS,5.2,"E"))
.S CITY=$G(BDAT(F,BIENS,5.3,"E"))
.S STATE=$G(BDAT(F,BIENS,5.4,"I"))
.S POSTAL=$G(BDAT(F,BIENS,5.5,"E"))
.S CC=$G(BDAT(F,BIENS,5.6,"E"))
.S PBMID=$G(BDAT(F,BIENS,15.1,"E"))
.S RPLN=$G(BDAT(F,BIENS,16.1,"E"))
.S RPFN=$G(BDAT(F,BIENS,16.2,"E"))
.S RPMN=$G(BDAT(F,BIENS,16.3,"E"))
.S RPSUFF=$G(BDAT(F,BIENS,16.4,"E"))
.S RPPREF=$G(BDAT(F,BIENS,16.5,"E"))
.S PAYTYPE=$G(BDAT(F,BIENS,16.6,"E"))
.D C S @GBL@(CNT,0)="<BenefitsCoordination>"
.I $L(PAYERID_PROCID_NAIC_MUTDEF_HPID_IIN) D
..D C S @GBL@(CNT,0)="<PayerIdentification>"
..D BL(GBL,.CNT,"PayerID",PAYERID)
..D BL(GBL,.CNT,"ProcessorIdentificationNumber",PROCID)
..D BL(GBL,.CNT,"NAICCode",NAIC)
..D BL(GBL,.CNT,"MutuallyDefined",MUTDEF)
..D BL(GBL,.CNT,"StandardUniqueHealthPlanIdentifier",HPID)
..D BL(GBL,.CNT,"IINNumber",IIN)
..D C S @GBL@(CNT,0)="</PayerIdentification>"
.D BL(GBL,.CNT,"PayerName",PAYNAME)
.D BL(GBL,.CNT,"CardholderID",CHID)
.D ONAME^PSOERXOU(GBL,.CNT,"CardHolderName",CHLN,CHFN,CHMN,CHSUFF,CHPREF)
.D BL(GBL,.CNT,"GroupID",GROUPID)
.D BL(GBL,.CNT,"PayerResponsibilityCode",PAYRCODE)
.D BL(GBL,.CNT,"PatientRelationshipCode",PATRCODE)
.D BL(GBL,.CNT,"PersonCode",PERCODE)
.D BL(GBL,.CNT,"GroupName",GNAME)
.D OADD^PSOERXOU(GBL,.CNT,ADL1,ADL2,CITY,STATE,POSTAL,CC)
.S SGBL=$NA(^PS(52.49,ERXIEN,304,BIEN,6))
.D OCOMM^PSOERXOU(GBL,SGBL,.CNT,BIEN_","_ERXIEN_",",52.493046,52.49304,7,BIEN_","_ERXIEN_",")
.;D BL(GBL,.CNT,"PBMMemberID",PBMID)
.D ONAME^PSOERXOU(GBL,.CNT,"ResponsibleParty",RPLN,RPFN,RPMN,RPSUFF,RPPREF)
.D BL(GBL,.CNT,"PayerType",PAYTYPE)
.D C S @GBL@(CNT,0)="</BenefitsCoordination>"
Q
OALLERGY(GBL,CNT,ERXIEN) ;outbound allergy segment
N AIEN,ADAT,AIENS,SOI,EFFDATE,EXPDATE,DPC,DPQ,DPT
N REATEXT,REACODE,SEVTEXT,SEVCODE,ADVTEXT,ADVCODE
S F=52.49303
I '$O(^PS(52.49,ERXIEN,303,0)) D Q
.S NKA=$$GET1^DIQ(52.49,ERXIEN,302,"I")
.D C S @GBL@(CNT,0)="<AllergyOrAdverseEvent>"
.D BL(GBL,.CNT,"NoKnownAllergies",NKA)
.D C S @GBL@(CNT,0)="</AllergyOrAdverseEvent>"
I $O(^PS(52.49,ERXIEN,303,0)) D
.D C S @GBL@(CNT,0)="<AllergyOrAdverseEvent>"
S AIEN=0 F S AIEN=$O(^PS(52.49,ERXIEN,303,AIEN)) Q:'AIEN D
.K ADAT
.S AIENS=AIEN_","_ERXIEN_","
.D GETS^DIQ(F,AIENS,"**","IE","ADAT")
.S SOI=$G(ADAT(F,AIENS,.02,"I"))
.S EFFDATE=$G(ADAT(F,AIENS,.03,"I")) I $G(EFFDATE) S EFFDATE=$P($$EXTIME^PSOERXO1(EFFDATE),"T")
.S EXPDATE=$G(ADAT(F,AIENS,.04,"I")) I $G(EXPDATE) S EXPDATE=$P($$EXTIME^PSOERXO1(EXPDATE),"T")
.S DPC=$G(ADAT(F,AIENS,1,"E"))
.S DPQ=$G(ADAT(F,AIENS,2,"E"))
.S DPT=$G(ADAT(F,AIENS,3,"E"))
.S REATEXT=$G(ADAT(F,AIENS,4,"E"))
.S REACODE=$G(ADAT(F,AIENS,5,"E"))
.S SEVTEXT=$G(ADAT(F,AIENS,6,"E"))
.S SEVCODE=$G(ADAT(F,AIENS,7,"E"))
.S ADVTEXT=$G(ADAT(F,AIENS,8,"E"))
.S ADVCODE=$G(ADAT(F,AIENS,9,"E"))
.D C S @GBL@(CNT,0)="<Allergies>"
.D BL(GBL,.CNT,"SourceOfInformation",SOI)
.I $L(EFFDATE) D
..D C S @GBL@(CNT,0)="<EffectiveDate>"
..D BL(GBL,.CNT,"Date",EFFDATE)
..D C S @GBL@(CNT,0)="</EffectiveDate>"
.I $L(EXPDATE) D
..D C S @GBL@(CNT,0)="<ExpirationDate>"
..D BL(GBL,.CNT,"Date",EXPDATE)
..D C S @GBL@(CNT,0)="</ExpirationDate>"
.D C S @GBL@(CNT,0)="<AdverseEvent>"
.D BL(GBL,.CNT,"Text",ADVTEXT)
.D BL(GBL,.CNT,"Code",ADVCODE)
.D C S @GBL@(CNT,0)="</AdverseEvent>"
.D C S @GBL@(CNT,0)="<DrugProductCoded>"
.D BL(GBL,.CNT,"Code",DPC)
.D BL(GBL,.CNT,"Qualifier",DPQ)
.D BL(GBL,.CNT,"Text",DPT)
.D C S @GBL@(CNT,0)="</DrugProductCoded>"
.I $L(REATEXT_REACODE) D
..D C S @GBL@(CNT,0)="<ReactionCoded>"
..D BL(GBL,.CNT,"Text",REATEXT)
..D BL(GBL,.CNT,"Code",REACODE)
..D C S @GBL@(CNT,0)="</ReactionCoded>"
.I $L(SEVTEXT_SEVCODE) D
..D C S @GBL@(CNT,0)="<SeverityCoded>"
..D BL(GBL,.CNT,"Text",SEVTEXT)
..D BL(GBL,.CNT,"Code",SEVCODE)
..D C S @GBL@(CNT,0)="</SeverityCoded>"
.D C S @GBL@(CNT,0)="</Allergies>"
D C S @GBL@(CNT,0)="</AllergyOrAdverseEvent>"
Q
OFAC(GBL,CNT,ERXIEN) ;outbound facility segment
N F,IENS,NCPDPID,STATELIC,MEDICARE,MEDICAID,UPIN,ID,DEA,HIM,NPE,MUTDEF,RESMID
N FACNAME,ADL1,ADL2,CITY,STATE,POSTAL,CC,FACDAT,HIN,NKA,NPI,REMSID
S F=52.49
S IENS=ERXIEN_","
D GETS^DIQ(F,IENS,"74.1;74.2;74.3;74.4;74.5;74.6;75.1;75.2;75.3;75.4;75.5;70.1;70.2;70.3;70.4;70.5;70.6;70.7","E","FACDAT")
S NCPDPID=$G(FACDAT(F,IENS,74.1,"E"))
S STATELIC=$G(FACDAT(F,IENS,74.2,"E"))
S MEDICARE=$G(FACDAT(F,IENS,74.3,"E"))
S MEDICAID=$G(FACDAT(F,IENS,74.4,"E"))
S UPIN=$G(FACDAT(F,IENS,74.5,"E"))
S ID=$G(FACDAT(F,IENS,74.6,"E"))
S DEA=$G(FACDAT(F,IENS,75.1,"E"))
S HIN=$G(FACDAT(F,IENS,75.2,"E"))
S NPI=$G(FACDAT(F,IENS,75.3,"E"))
S MUTDEF=$G(FACDAT(F,IENS,75.4,"E"))
S REMSID=$G(FACDAT(F,IENS,75.5,"E"))
S FACNAME=$G(FACDAT(F,IENS,70.1,"E"))
S ADL1=$G(FACDAT(F,IENS,70.2,"E"))
S ADL2=$G(FACDAT(F,IENS,70.3,"E"))
S CITY=$G(FACDAT(F,IENS,70.4,"E"))
S STATE=$G(FACDAT(F,IENS,70.5,"I"))
S POSTAL=$G(FACDAT(F,IENS,70.6,"E"))
S CC=$G(FACDAT(F,IENS,70.7,"E"))
I $L(NCPDPID_STATELIC_MEDICARE_MEDICAID_UPIN_ID_DEA_HIN_NPI_MUTDEF_REMSID) D
.D C S @GBL@(CNT,0)="<Facility>"
.D C S @GBL@(CNT,0)="<Identification>"
.D BL(GBL,.CNT,"NCPDPIP",NCPDPID)
.D BL(GBL,.CNT,"StateLicenseNumber",STATELIC)
.D BL(GBL,.CNT,"MedicareNumber",MEDICARE)
.D BL(GBL,.CNT,"MedicaidNumber",MEDICAID)
.D BL(GBL,.CNT,"UPIN",UPIN)
.D BL(GBL,.CNT,"FacilityID",ID)
.D BL(GBL,.CNT,"DEANumber",DEA)
.D BL(GBL,.CNT,"HIN",HIN)
.D BL(GBL,.CNT,"NPI",NPI)
.D BL(GBL,.CNT,"MutuallyDefined",MUTDEF)
.D BL(GBL,.CNT,"REMSHealthcareSettingEnrollmentID",REMSID)
.D C S @GBL@(CNT,0)="</Identification>"
.D BL(GBL,.CNT,"FacilityName",FACNAME)
.D OADD^PSOERXOU(GBL,.CNT,ADL1,ADL2,CITY,STATE,POSTAL,CC)
.S SGBL=$NA(^PS(52.49,ERXIEN,73))
.D OCOMM^PSOERXOU(GBL,SGBL,.CNT,ERXIEN_",",52.4973,52.49,76,ERXIEN_",")
.D C S @GBL@(CNT,0)="</Facility>"
Q
OOBSERVE(GL,CNT,ERXIEN) ;outbound observation segment
N OIEN,OIENS,ODAT,VITAL,LOINC,VALUE,UOM,UCUM,OBDATE,OBNOTE,FOUND,OBS
; Must find at least one Observation with a valid date in order to include the <Observation> section
S (FOUND,OBS)=0 F S OBS=$O(^PS(52.49,ERXIEN,306,OBS)) Q:'OBS I $G(^PS(52.49,ERXIEN,306,OBS,6)) S FOUND=1 Q
I 'FOUND Q
D C S @GBL@(CNT,0)="<Observation>"
S OIEN=0 F S OIEN=$O(^PS(52.49,ERXIEN,306,OIEN)) Q:'OIEN D
.S F=52.49306
.K ODAT
.S OIENS=OIEN_","_ERXIEN_","
.D GETS^DIQ(F,OIENS,"**","IE","ODAT")
.S VITAL=$G(ODAT(F,OIENS,1,"E"))
.S LOINC=$G(ODAT(F,OIENS,2,"E"))
.S VALUE=$G(ODAT(F,OIENS,3,"E"))
.S UOM=$G(ODAT(F,OIENS,4,"E"))
.S UCUM=$G(ODAT(F,OIENS,5,"E"))
.S OBDATE=$G(ODAT(F,OIENS,6,"I")) I 'OBDATE Q
.S OBDATE=$P($$EXTIME^PSOERXO1(OBDATE),"T")
.I $L(VITAL_LOINC_VALUE_UOM_UCUM) D
..D C S @GBL@(CNT,0)="<Measurement>"
..D BL(GBL,.CNT,"VitalSign",VITAL)
..D BL(GBL,.CNT,"LOINCVersion",LOINC)
..D BL(GBL,.CNT,"Value",VALUE)
..D BL(GBL,.CNT,"UnitOfMeasure",UOM)
..D BL(GBL,.CNT,"UCUMVersion",UCUM)
..I $L(OBDATE) D
...D C S @GBL@(CNT,0)="<ObservationDate>"
...D BL(GBL,.CNT,"Date",OBDATE)
...D C S @GBL@(CNT,0)="</ObservationDate>"
..D C S @GBL@(CNT,0)="</Measurement>"
S OBNOTE=$$GET1^DIQ(52.49,ERXIEN,305,"E")
D BL(GBL,.CNT,"ObservationNotes",OBNOTE)
D C S @GBL@(CNT,0)="</Observation>"
Q
BL(GBL,CNT,TAG,VAR) ;
Q:VAR=""
D C S @GBL@(CNT,0)="<"_TAG_">"_$$SYMENC^MXMLUTL(VAR)_"</"_TAG_">"
Q
C ;
S CNT=$G(CNT)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXOB 8748 printed Apr 09, 2024@21:36:51 Page 2
PSOERXOB ;ALB/BWF - eRx parsing Utilities ; 11/14/2019 3:46pm
+1 ;;7.0;OUTPATIENT PHARMACY;**581,651**;DEC 1997;Build 30
+2 ;
+3 QUIT
OBENEFIT(GBL,CNT,ERXIEN) ;outbound benefits coordination section
+1 NEW F,BIEN,SGBL,BDAT,PAYERID,PROCID,NAIC,MUTDEF,PHID,IIN,PAYNAME,CHID,CHLN,CHFN,CHMN,CHSUFF
+2 NEW GROUPID,PAYRCODE,PATRCODE,PERCODE,GNAME,ADL1,ADL2,CITY,STATE,HPID
+3 NEW POSTAL,CC,PBMID,RPLN,RPFN,RPMN,RPSUFF,RPPREF,PAYTYPE,BIENS,CHPREF
+4 SET F=52.49304
+5 IF '$ORDER(^PS(52.49,ERXIEN,304,0))
QUIT
+6 SET BIEN=0
FOR
SET BIEN=$ORDER(^PS(52.49,ERXIEN,304,BIEN))
if 'BIEN
QUIT
Begin DoDot:1
+7 KILL BDAT
+8 SET BIENS=BIEN_","_ERXIEN_","
+9 DO GETS^DIQ(F,BIENS,"**","IE","BDAT")
+10 SET PAYERID=$GET(BDAT(F,BIENS,.02,"E"))
+11 SET PROCID=$GET(BDAT(F,BIENS,.03,"E"))
+12 SET NAIC=$GET(BDAT(F,BIENS,.04,"E"))
+13 SET MUTDEF=$GET(BDAT(F,BIENS,1.1,"E"))
+14 SET HPID=$GET(BDAT(F,BIENS,1.2,"E"))
+15 SET IIN=$GET(BDAT(F,BIENS,1.3,"E"))
+16 SET PAYNAME=$GET(BDAT(F,BIENS,2.1,"E"))
+17 SET CHID=$GET(BDAT(F,BIENS,2.2,"E"))
+18 SET CHLN=$GET(BDAT(F,BIENS,3.1,"E"))
+19 SET CHFN=$GET(BDAT(F,BIENS,3.2,"E"))
+20 SET CHMN=$GET(BDAT(F,BIENS,3.3,"E"))
+21 SET CHSUFF=$GET(BDAT(F,BIENS,3.4,"E"))
+22 SET CHPREF=$GET(BDAT(F,BIENS,3.5,"E"))
+23 SET GROUPID=$GET(BDAT(F,BIENS,4.1,"E"))
+24 SET PAYRCODE=$GET(BDAT(F,BIENS,4.3,"I"))
+25 SET PATRCODE=$GET(BDAT(F,BIENS,4.4,"I"))
+26 SET PERCODE=$GET(BDAT(F,BIENS,4.5,"E"))
+27 SET GNAME=$GET(BDAT(F,BIENS,4.6,"E"))
+28 SET ADL1=$GET(BDAT(F,BIENS,5.1,"E"))
+29 SET ADL2=$GET(BDAT(F,BIENS,5.2,"E"))
+30 SET CITY=$GET(BDAT(F,BIENS,5.3,"E"))
+31 SET STATE=$GET(BDAT(F,BIENS,5.4,"I"))
+32 SET POSTAL=$GET(BDAT(F,BIENS,5.5,"E"))
+33 SET CC=$GET(BDAT(F,BIENS,5.6,"E"))
+34 SET PBMID=$GET(BDAT(F,BIENS,15.1,"E"))
+35 SET RPLN=$GET(BDAT(F,BIENS,16.1,"E"))
+36 SET RPFN=$GET(BDAT(F,BIENS,16.2,"E"))
+37 SET RPMN=$GET(BDAT(F,BIENS,16.3,"E"))
+38 SET RPSUFF=$GET(BDAT(F,BIENS,16.4,"E"))
+39 SET RPPREF=$GET(BDAT(F,BIENS,16.5,"E"))
+40 SET PAYTYPE=$GET(BDAT(F,BIENS,16.6,"E"))
+41 DO C
SET @GBL@(CNT,0)="<BenefitsCoordination>"
+42 IF $LENGTH(PAYERID_PROCID_NAIC_MUTDEF_HPID_IIN)
Begin DoDot:2
+43 DO C
SET @GBL@(CNT,0)="<PayerIdentification>"
+44 DO BL(GBL,.CNT,"PayerID",PAYERID)
+45 DO BL(GBL,.CNT,"ProcessorIdentificationNumber",PROCID)
+46 DO BL(GBL,.CNT,"NAICCode",NAIC)
+47 DO BL(GBL,.CNT,"MutuallyDefined",MUTDEF)
+48 DO BL(GBL,.CNT,"StandardUniqueHealthPlanIdentifier",HPID)
+49 DO BL(GBL,.CNT,"IINNumber",IIN)
+50 DO C
SET @GBL@(CNT,0)="</PayerIdentification>"
End DoDot:2
+51 DO BL(GBL,.CNT,"PayerName",PAYNAME)
+52 DO BL(GBL,.CNT,"CardholderID",CHID)
+53 DO ONAME^PSOERXOU(GBL,.CNT,"CardHolderName",CHLN,CHFN,CHMN,CHSUFF,CHPREF)
+54 DO BL(GBL,.CNT,"GroupID",GROUPID)
+55 DO BL(GBL,.CNT,"PayerResponsibilityCode",PAYRCODE)
+56 DO BL(GBL,.CNT,"PatientRelationshipCode",PATRCODE)
+57 DO BL(GBL,.CNT,"PersonCode",PERCODE)
+58 DO BL(GBL,.CNT,"GroupName",GNAME)
+59 DO OADD^PSOERXOU(GBL,.CNT,ADL1,ADL2,CITY,STATE,POSTAL,CC)
+60 SET SGBL=$NAME(^PS(52.49,ERXIEN,304,BIEN,6))
+61 DO OCOMM^PSOERXOU(GBL,SGBL,.CNT,BIEN_","_ERXIEN_",",52.493046,52.49304,7,BIEN_","_ERXIEN_",")
+62 ;D BL(GBL,.CNT,"PBMMemberID",PBMID)
+63 DO ONAME^PSOERXOU(GBL,.CNT,"ResponsibleParty",RPLN,RPFN,RPMN,RPSUFF,RPPREF)
+64 DO BL(GBL,.CNT,"PayerType",PAYTYPE)
+65 DO C
SET @GBL@(CNT,0)="</BenefitsCoordination>"
End DoDot:1
+66 QUIT
OALLERGY(GBL,CNT,ERXIEN) ;outbound allergy segment
+1 NEW AIEN,ADAT,AIENS,SOI,EFFDATE,EXPDATE,DPC,DPQ,DPT
+2 NEW REATEXT,REACODE,SEVTEXT,SEVCODE,ADVTEXT,ADVCODE
+3 SET F=52.49303
+4 IF '$ORDER(^PS(52.49,ERXIEN,303,0))
Begin DoDot:1
+5 SET NKA=$$GET1^DIQ(52.49,ERXIEN,302,"I")
+6 DO C
SET @GBL@(CNT,0)="<AllergyOrAdverseEvent>"
+7 DO BL(GBL,.CNT,"NoKnownAllergies",NKA)
+8 DO C
SET @GBL@(CNT,0)="</AllergyOrAdverseEvent>"
End DoDot:1
QUIT
+9 IF $ORDER(^PS(52.49,ERXIEN,303,0))
Begin DoDot:1
+10 DO C
SET @GBL@(CNT,0)="<AllergyOrAdverseEvent>"
End DoDot:1
+11 SET AIEN=0
FOR
SET AIEN=$ORDER(^PS(52.49,ERXIEN,303,AIEN))
if 'AIEN
QUIT
Begin DoDot:1
+12 KILL ADAT
+13 SET AIENS=AIEN_","_ERXIEN_","
+14 DO GETS^DIQ(F,AIENS,"**","IE","ADAT")
+15 SET SOI=$GET(ADAT(F,AIENS,.02,"I"))
+16 SET EFFDATE=$GET(ADAT(F,AIENS,.03,"I"))
IF $GET(EFFDATE)
SET EFFDATE=$PIECE($$EXTIME^PSOERXO1(EFFDATE),"T")
+17 SET EXPDATE=$GET(ADAT(F,AIENS,.04,"I"))
IF $GET(EXPDATE)
SET EXPDATE=$PIECE($$EXTIME^PSOERXO1(EXPDATE),"T")
+18 SET DPC=$GET(ADAT(F,AIENS,1,"E"))
+19 SET DPQ=$GET(ADAT(F,AIENS,2,"E"))
+20 SET DPT=$GET(ADAT(F,AIENS,3,"E"))
+21 SET REATEXT=$GET(ADAT(F,AIENS,4,"E"))
+22 SET REACODE=$GET(ADAT(F,AIENS,5,"E"))
+23 SET SEVTEXT=$GET(ADAT(F,AIENS,6,"E"))
+24 SET SEVCODE=$GET(ADAT(F,AIENS,7,"E"))
+25 SET ADVTEXT=$GET(ADAT(F,AIENS,8,"E"))
+26 SET ADVCODE=$GET(ADAT(F,AIENS,9,"E"))
+27 DO C
SET @GBL@(CNT,0)="<Allergies>"
+28 DO BL(GBL,.CNT,"SourceOfInformation",SOI)
+29 IF $LENGTH(EFFDATE)
Begin DoDot:2
+30 DO C
SET @GBL@(CNT,0)="<EffectiveDate>"
+31 DO BL(GBL,.CNT,"Date",EFFDATE)
+32 DO C
SET @GBL@(CNT,0)="</EffectiveDate>"
End DoDot:2
+33 IF $LENGTH(EXPDATE)
Begin DoDot:2
+34 DO C
SET @GBL@(CNT,0)="<ExpirationDate>"
+35 DO BL(GBL,.CNT,"Date",EXPDATE)
+36 DO C
SET @GBL@(CNT,0)="</ExpirationDate>"
End DoDot:2
+37 DO C
SET @GBL@(CNT,0)="<AdverseEvent>"
+38 DO BL(GBL,.CNT,"Text",ADVTEXT)
+39 DO BL(GBL,.CNT,"Code",ADVCODE)
+40 DO C
SET @GBL@(CNT,0)="</AdverseEvent>"
+41 DO C
SET @GBL@(CNT,0)="<DrugProductCoded>"
+42 DO BL(GBL,.CNT,"Code",DPC)
+43 DO BL(GBL,.CNT,"Qualifier",DPQ)
+44 DO BL(GBL,.CNT,"Text",DPT)
+45 DO C
SET @GBL@(CNT,0)="</DrugProductCoded>"
+46 IF $LENGTH(REATEXT_REACODE)
Begin DoDot:2
+47 DO C
SET @GBL@(CNT,0)="<ReactionCoded>"
+48 DO BL(GBL,.CNT,"Text",REATEXT)
+49 DO BL(GBL,.CNT,"Code",REACODE)
+50 DO C
SET @GBL@(CNT,0)="</ReactionCoded>"
End DoDot:2
+51 IF $LENGTH(SEVTEXT_SEVCODE)
Begin DoDot:2
+52 DO C
SET @GBL@(CNT,0)="<SeverityCoded>"
+53 DO BL(GBL,.CNT,"Text",SEVTEXT)
+54 DO BL(GBL,.CNT,"Code",SEVCODE)
+55 DO C
SET @GBL@(CNT,0)="</SeverityCoded>"
End DoDot:2
+56 DO C
SET @GBL@(CNT,0)="</Allergies>"
End DoDot:1
+57 DO C
SET @GBL@(CNT,0)="</AllergyOrAdverseEvent>"
+58 QUIT
OFAC(GBL,CNT,ERXIEN) ;outbound facility segment
+1 NEW F,IENS,NCPDPID,STATELIC,MEDICARE,MEDICAID,UPIN,ID,DEA,HIM,NPE,MUTDEF,RESMID
+2 NEW FACNAME,ADL1,ADL2,CITY,STATE,POSTAL,CC,FACDAT,HIN,NKA,NPI,REMSID
+3 SET F=52.49
+4 SET IENS=ERXIEN_","
+5 DO GETS^DIQ(F,IENS,"74.1;74.2;74.3;74.4;74.5;74.6;75.1;75.2;75.3;75.4;75.5;70.1;70.2;70.3;70.4;70.5;70.6;70.7","E","FACDAT")
+6 SET NCPDPID=$GET(FACDAT(F,IENS,74.1,"E"))
+7 SET STATELIC=$GET(FACDAT(F,IENS,74.2,"E"))
+8 SET MEDICARE=$GET(FACDAT(F,IENS,74.3,"E"))
+9 SET MEDICAID=$GET(FACDAT(F,IENS,74.4,"E"))
+10 SET UPIN=$GET(FACDAT(F,IENS,74.5,"E"))
+11 SET ID=$GET(FACDAT(F,IENS,74.6,"E"))
+12 SET DEA=$GET(FACDAT(F,IENS,75.1,"E"))
+13 SET HIN=$GET(FACDAT(F,IENS,75.2,"E"))
+14 SET NPI=$GET(FACDAT(F,IENS,75.3,"E"))
+15 SET MUTDEF=$GET(FACDAT(F,IENS,75.4,"E"))
+16 SET REMSID=$GET(FACDAT(F,IENS,75.5,"E"))
+17 SET FACNAME=$GET(FACDAT(F,IENS,70.1,"E"))
+18 SET ADL1=$GET(FACDAT(F,IENS,70.2,"E"))
+19 SET ADL2=$GET(FACDAT(F,IENS,70.3,"E"))
+20 SET CITY=$GET(FACDAT(F,IENS,70.4,"E"))
+21 SET STATE=$GET(FACDAT(F,IENS,70.5,"I"))
+22 SET POSTAL=$GET(FACDAT(F,IENS,70.6,"E"))
+23 SET CC=$GET(FACDAT(F,IENS,70.7,"E"))
+24 IF $LENGTH(NCPDPID_STATELIC_MEDICARE_MEDICAID_UPIN_ID_DEA_HIN_NPI_MUTDEF_REMSID)
Begin DoDot:1
+25 DO C
SET @GBL@(CNT,0)="<Facility>"
+26 DO C
SET @GBL@(CNT,0)="<Identification>"
+27 DO BL(GBL,.CNT,"NCPDPIP",NCPDPID)
+28 DO BL(GBL,.CNT,"StateLicenseNumber",STATELIC)
+29 DO BL(GBL,.CNT,"MedicareNumber",MEDICARE)
+30 DO BL(GBL,.CNT,"MedicaidNumber",MEDICAID)
+31 DO BL(GBL,.CNT,"UPIN",UPIN)
+32 DO BL(GBL,.CNT,"FacilityID",ID)
+33 DO BL(GBL,.CNT,"DEANumber",DEA)
+34 DO BL(GBL,.CNT,"HIN",HIN)
+35 DO BL(GBL,.CNT,"NPI",NPI)
+36 DO BL(GBL,.CNT,"MutuallyDefined",MUTDEF)
+37 DO BL(GBL,.CNT,"REMSHealthcareSettingEnrollmentID",REMSID)
+38 DO C
SET @GBL@(CNT,0)="</Identification>"
+39 DO BL(GBL,.CNT,"FacilityName",FACNAME)
+40 DO OADD^PSOERXOU(GBL,.CNT,ADL1,ADL2,CITY,STATE,POSTAL,CC)
+41 SET SGBL=$NAME(^PS(52.49,ERXIEN,73))
+42 DO OCOMM^PSOERXOU(GBL,SGBL,.CNT,ERXIEN_",",52.4973,52.49,76,ERXIEN_",")
+43 DO C
SET @GBL@(CNT,0)="</Facility>"
End DoDot:1
+44 QUIT
OOBSERVE(GL,CNT,ERXIEN) ;outbound observation segment
+1 NEW OIEN,OIENS,ODAT,VITAL,LOINC,VALUE,UOM,UCUM,OBDATE,OBNOTE,FOUND,OBS
+2 ; Must find at least one Observation with a valid date in order to include the <Observation> section
+3 SET (FOUND,OBS)=0
FOR
SET OBS=$ORDER(^PS(52.49,ERXIEN,306,OBS))
if 'OBS
QUIT
IF $GET(^PS(52.49,ERXIEN,306,OBS,6))
SET FOUND=1
QUIT
+4 IF 'FOUND
QUIT
+5 DO C
SET @GBL@(CNT,0)="<Observation>"
+6 SET OIEN=0
FOR
SET OIEN=$ORDER(^PS(52.49,ERXIEN,306,OIEN))
if 'OIEN
QUIT
Begin DoDot:1
+7 SET F=52.49306
+8 KILL ODAT
+9 SET OIENS=OIEN_","_ERXIEN_","
+10 DO GETS^DIQ(F,OIENS,"**","IE","ODAT")
+11 SET VITAL=$GET(ODAT(F,OIENS,1,"E"))
+12 SET LOINC=$GET(ODAT(F,OIENS,2,"E"))
+13 SET VALUE=$GET(ODAT(F,OIENS,3,"E"))
+14 SET UOM=$GET(ODAT(F,OIENS,4,"E"))
+15 SET UCUM=$GET(ODAT(F,OIENS,5,"E"))
+16 SET OBDATE=$GET(ODAT(F,OIENS,6,"I"))
IF 'OBDATE
QUIT
+17 SET OBDATE=$PIECE($$EXTIME^PSOERXO1(OBDATE),"T")
+18 IF $LENGTH(VITAL_LOINC_VALUE_UOM_UCUM)
Begin DoDot:2
+19 DO C
SET @GBL@(CNT,0)="<Measurement>"
+20 DO BL(GBL,.CNT,"VitalSign",VITAL)
+21 DO BL(GBL,.CNT,"LOINCVersion",LOINC)
+22 DO BL(GBL,.CNT,"Value",VALUE)
+23 DO BL(GBL,.CNT,"UnitOfMeasure",UOM)
+24 DO BL(GBL,.CNT,"UCUMVersion",UCUM)
+25 IF $LENGTH(OBDATE)
Begin DoDot:3
+26 DO C
SET @GBL@(CNT,0)="<ObservationDate>"
+27 DO BL(GBL,.CNT,"Date",OBDATE)
+28 DO C
SET @GBL@(CNT,0)="</ObservationDate>"
End DoDot:3
+29 DO C
SET @GBL@(CNT,0)="</Measurement>"
End DoDot:2
End DoDot:1
+30 SET OBNOTE=$$GET1^DIQ(52.49,ERXIEN,305,"E")
+31 DO BL(GBL,.CNT,"ObservationNotes",OBNOTE)
+32 DO C
SET @GBL@(CNT,0)="</Observation>"
+33 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
