- BYIMSEGS ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
- ;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22
- ;
- ;code to supplement fields in the HL7 segments
- ;
- MSH ;EP;entry point
- D PATH^BYIMIMM6
- D NOW^%DTC
- S INA("EVDT")=%
- S INA("ENC")=$$COMP^INHUT()_$$REP^INHUT()_$$SUBCOMP^INHUT()_$$ESC^INHUT()
- S INA("MT")=$P($G(^INTHL7M(BHLMIEN,0)),U,6)
- S INA("ET")=$P($G(^INTHL7M(BHLMIEN,0)),U,2)
- S INA("ACA")=$P($G(^INTHL7M(BHLMIEN,0)),U,10)
- S INA("APA")=$P($G(^INTHL7M(BHLMIEN,0)),U,11)
- S INA("VER")=BYIMVER
- S INA("PRID")=$P($G(^INTHL7M(BHLMIEN,0)),U,3)
- S INA("SAP")=$P($G(^INTHL7M(BHLMIEN,7)),U)
- S INA("SF")=$P($G(^INTHL7M(BHLMIEN,7)),U,2)
- S INA("RAP")=$P($G(^INTHL7M(BHLMIEN,7)),U,3)
- S INA("RF")=$P($G(^INTHL7M(BHLMIEN,7)),U,4)
- D MSH3
- D MSH4
- D MSH5
- D MSH6
- D MSH7
- D MSH8
- D MSH9
- D MSH10
- D MSH11
- D MSH12
- Q
- ;-----
- MSH3 ;
- S X=BYIM("MSH3.1")
- S:X="" X="RPMS"
- I BYIM("MSH3.2")]"" S X=X_CS_BYIM("MSH3.2")_CS_$S($G(BYIM("MSH3.3")):BYIM("MSH3.3"),1:"ISO")
- S INA("MSH3")=X
- Q
- ;-----
- MSH4 ;
- N X
- S X=BYIM("MSH4.1")
- S:X="" X=$P($G(^DIC(4,$$DUZ^BYIMIMM(),0)),U)
- I BYIM("MSH4.2")]"" S X=X_CS_BYIM("MSH4.2")_CS_$S($G(BYIM("MSH4.3")):BYIM("MSH4.3"),1:"ISO")
- S INA("MSH4")=X
- Q
- ;-----
- MSH5 ;
- S X=BYIM("MSH5.1")
- I BYIM("MSH5.2")]"" S X=X_CS_BYIM("MSH5.2")_CS_$S($G(BYIM("MSH5.3")):BYIM("MSH5.3"),1:"ISO")
- S INA("MSH5")=X
- Q
- ;-----
- MSH6 ;
- S INA("MSH6")=BYIM("MSH6")
- Q
- ;-----
- MSH7 ;
- D NOW^%DTC
- S INA("MSH7")=$P($$TIMEIO^INHUT10(%),"-")
- Q
- ;-----
- MSH8 ;
- S INA("MSH8")=BYIMMSH8
- Q
- ;-----
- MSH9 ;
- S INA("MSH9")=INA("MT")_CS_INA("ET")_CS_INA("MT")_"_"_INA("ET")
- Q
- ;-----
- MSH10 ;
- S INA("MSH10")=$P($G(^INTHU(+$G(UIF),0)),U,5)
- S:INA("MSH10")="" INA("MSH10")=$$MESSID^INHD()
- Q
- ;-----
- MSH11 ;
- S INA("MSH11")="P"
- Q
- ;-----
- MSH12 ;
- S INA("MSH12")=BYIMVER
- Q
- ;-----
- MSHEND Q
- ;-----
- PID ;EP;
- D PID3
- D PID5
- D PID6
- D PID7
- D PID10
- D PID11
- D PID13
- D PID14
- D PID19
- D PID22
- D PID24
- Q
- ;-----
- PID3 ;PID-3 HRN
- N X,Y,Z
- S X=$$HRN^BYIMIMM3(INDA)
- ;PATCH 8 CR 08549 - OVERRIDE SSN EXCLUSION FOR MULTIPLE STATE FILES
- ;PATCH 6 ALLOW EXCLUSION OF SSN
- ;I '$G(BYIMESSN) D
- ;S Y=$TR($P($G(^DPT(INDA,0)),U,9),"-")
- ;S:Y]"" X=X_"~"_Y_CS_CS_CS_"SSA"_CS_"SS"
- ;PATCH 6 ALLOW EXCLUSION OF SSN
- ;PATCH 8 CR 08549 END
- S Y=""
- S Z=$O(^AUPNMCD("B",INDA,9999999999),-1)
- S:Z Y=$P($G(^AUPNMCD(Z,0)),U,3)
- S:Y]"" X=X_"~"_Y_CS_CS_CS_"MCD"_CS_"MA"
- ;PATCH 9 MEDICARE NUMBER
- ;AUPN V99.1 PATCH 26 REQUIRED
- S Y=""
- S Y=$$GETMCR^AGUTL(INDA,DT)
- I $L(Y) S X=X_"~"_Y_CS_CS_CS_"MEDICARE"_CS_"MC"
- ;PATCH 9 END
- S INA("PID3")=X
- S INA("PID3",1)=X
- Q
- ;-----
- PID5 ;PID-5 NAME
- N X,Y,Z
- S X=$P($G(^DPT(INDA,0)),U)
- S Y=$P($P(X,",",2)," ")
- S Z=$P($P(X,",",2)," ",2)
- S X=$P(X,",")
- S INA("PID5")=X_CS_Y_CS_Z_CS_CS_CS_CS_"L"
- S INA("PID5",1)=INA("PID5")
- Q
- ;-----
- PID6 ;PID-6 MMN
- N X,Y,Z
- S X=$P($G(^DPT(INDA,.24)),U,3)
- S Y=$P($P(X,",",2)," ")
- S Z=$P($P(X,",",2)," ",2)
- S X=$P(X,",")
- ;name type for MMN
- S INA("PID6")=$S(X]"":(X_CS_Y_CS_Z_CS_CS_CS_CS_"M"),1:"")
- S INA("PID6",1)=INA("PID6")
- Q
- ;-----
- PID7 ;PID-7 DOB
- S INA("PID7")=17000000+$P($G(^DPT(INDA,0)),U,3)
- S INA("PID7",1)=INA("PID7")
- Q
- ;-----
- PID10 ;PID-10 RACE
- S INA("PID10")=$$RACE^BYIMIMM3(INDA)
- S INA("PID10",1)=INA("PID10")
- Q
- ;-----
- PID11 ;PID-11 ADDRESS
- S X=$G(^DPT(+INDA,.11))
- ;PATCH 8 CR 08631 - PATIENT ADDRESS TYPE
- S INA("PID11")=$P(X,U)_CS_CS_$P(X,U,4)_CS_$P($G(^DIC(5,+$P(X,U,5),0)),U,2)_CS_$P(X,U,6)_CS_"USA"_CS_$S($G(BYIMATYP)]"":BYIMATYP,1:"L")
- ;PATCH 8 CR 08631 END
- S INA("PID11",1)=INA("PID11")
- Q
- ;-----
- PID13 ;PID-13 PHONE HOME
- S INA("PID13")=""
- S INA("PID13",1)=""
- S X=$P($G(^DPT(INDA,.13)),U)
- S X=$TR(X,"()\/- ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
- S:$E(X)=1 X=$E(X,2,99)
- I X'?10N S INA("PID13")=""
- D:X?10N
- .D:BYIMVER>2.4
- ..S INA("PID13")=CS_"PRN"_CS_"PH"_CS_CS_CS_$E(X,1,3)_CS_$E(X,4,10)
- ..S INA("PID13",1)=INA("PID13")
- .D:BYIMVER<2.5
- ..S INA("PID13")="("_$E(X,1,3)_")"_$E(X,4,6)_"-"_$E(X,7,10)_CS_"PRN"_CS_"PH"
- ..S INA("PID13",1)=INA("PID13")
- S X=$P($G(^AUPNPAT(INDA,18)),U,2)
- Q:X=""
- S X="~^NET^^"_X
- S INA("PID13")=INA("PID13")_X
- S INA("PID13",1)=INA("PID13")
- Q
- ;-----
- PID14 ;PID-14 PHONE BUSINESS
- S INA("PID14")=""
- S INA("PID14",1)=""
- S X=$P($G(^DPT(INDA,.13)),U,2)
- S X=$TR(X,"()\/- ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
- S:$E(X)=1 X=$E(X,2,99)
- I X'?10N S INA("PID14",1)="" Q
- D:BYIMVER["2.5"
- .S INA("PID14")=CS_"WPN"_CS_"PH"_CS_CS_CS_$E(X,1,3)_CS_$E(X,4,10)
- .S INA("PID14",1)=INA("PID14")
- D:BYIMVER'["2.5"
- .S INA("PID14")="("_$E(X,1,3)_")"_$E(X,4,6)_"-"_$E(X,7,10)_CS_"WPN"_CS_"PH"
- .S INA("PID14",1)=INA("PID14")
- Q
- ;-----
- PID19 ;PID-19 SSN
- S Y=$TR($P($G(^DPT(INDA,0)),U,9),"-")
- S:Y]"" X=Y_CS_CS_CS_"SSA"_CS_"SS"
- ;S INA("PID19")=X
- ;S INA("PID19",1)=X
- Q
- ;-----
- PID22 ;PID-22 ETHNICITY
- S INA("PID22")=$$ETH^BYIMIMM3(INDA)
- S INA("PID22",1)=INA("PID22")
- Q
- ;-----
- PID24 ;PID-24 BIRTH ORDER
- S INA("PID24")="N"
- S INA("PID24",1)="N"
- PIDEND Q
- ;-----
- PD1 ;EP;
- D PD1^BYIMSEG1
- PD1END Q
- ;-----
- NK1 ; generate the NK1 segment
- D NK11
- D NK12
- D NK13
- D NK14
- D NK15
- D NK17
- Q
- ;-----
- NK11 ;subid
- S INA("NK11")="1"
- S INA("NK11",1)="1"
- Q
- ;-----
- NK12 N X,FN,LN,MN
- S X=$P($G(^DPT(INDA,.21)),U)
- S LN=$P(X,",")
- S FN=$P($P(X,",",2)," ")
- S MN=$P($P(X,",",2)," ",2)
- ;PATCH 7 USE DEFAULT LN AND FN IF NOT DEFINED
- S:LN="" LN="LAST_NAME"
- S:FN="" FN="FIRST_NAME"
- S INA("NK12")=LN_CS_FN_CS_MN_CS_CS_CS_CS_"L"
- S INA("NK12",1)=INA("NK12")
- Q
- ;-----
- NK13 N X
- S X=+$P($G(^AUPNPAT(INDA,28)),U,2)
- S Y=$G(^BYIMCDC(+$P($G(^BYIMREL(X,0)),U,2),0))
- S:Y]"" X=$P(Y,U,2),Y=$P(Y,U)
- S:Y="" Y="OTH",X="OTHER"
- S INA("NK13")=Y_CS_X_CS_"HL70063"
- S INA("NK13",1)=INA("NK13")
- Q
- ;-----
- NK14 ;NOK ADDRESS
- S X=$P($G(^DPT(+INDA,.21)),U,3,8)
- S X=$P(X,U)_CS_CS_$P(X,U,4)_CS_$P($G(^DIC(5,+$P(X,U,5),0)),U,2)_CS_$P(X,U,6)_CS_"USA"_CS_"L"
- S INA("NK14")=X
- S INA("NK14",1)=X
- Q
- ;-----
- NK15 ;PHONE NUMBER
- S INA("NK15")=""
- S X=$P($G(^DPT(INDA,.21)),U,9)
- S X=$TR(X,"()\/- ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
- S:$E(X)=1 X=$E(X,2,99)
- I X'?10N S INA("NK15",1)="" Q
- D:BYIMVER["2.5"
- .S INA("NK15")=CS_"PRN"_CS_"PH"_CS_CS_CS_$E(X,1,3)_CS_$E(X,4,10)
- .S INA("NK15",1)=INA("NK15")
- D:BYIMVER'["2.5"
- .S INA("NK15")="("_$E(X,1,3)_")"_$E(X,4,6)_"-"_$E(X,7,10)_CS_"PRN"_CS_"PH"
- .S INA("NK15",1)=INA("NK15")
- Q
- ;-----
- NK17 ;CONTACT
- S INA("NK17")="NOK^NEXT OF KIN"
- S INA("NK17",1)="NOK^NEXT OF KIN"
- Q
- ;-----
- NK1END Q
- ;-----
- PV1 ;EP;FOR PV1 SEGMENT CONTENT
- ;PATCH 7 ADD PV1 COMPONENT
- D PV11
- D PV12
- D PV13
- D PV17
- D PV19
- D PV119
- D PV120
- D PV144
- Q
- ;-----
- PV11 ;PV1-01
- S INA("PV11",1)=1
- Q
- ;-----
- PV12 ;PV1-02
- S INA("PV12",1)="R"
- Q
- ;-----
- PV13 ;PV1-03 PAT LOC
- S INA("PV13",1)=""
- Q
- ;-----
- PV17 ;PV1-07
- S INA("PV17",1)=""
- S P=$$PRIMPROV^APCLV(INDA,"I")
- Q:'P
- S X=$$PROV(P)
- S INA("PV17",1)=X
- Q
- ;-----
- PV19 ;PV1-09
- S INA("PV19",1)=""
- S P=$$PRIMPROV^APCLV(INDA,"I")
- Q:'P
- S X=$$PROV(P)
- S INA("PV19",1)=X
- Q
- ;-----
- PV119 ;PV1-19
- ;PATCH 7
- S INA("PV119",1)=INDA_CS_CS_CS_"RPMS"_CS_"MR"
- Q
- ;-----
- PV120 ;PV1-20 VFC
- S INA("PV120",1)=$$VFC^BYIMIMM3(INDA)
- Q
- ;-----
- PV144 ;PV1-44 VISIT DATE
- N X,Y,Z
- S INA("PV144",1)=""
- S X=$P($G(^AUPNVSIT(+$G(INDA),0)),".")
- Q:$L(X)'=7
- S INA("PV144",1)=X+17000000
- PV1END Q
- ;-----
- ORC ;EP; - for ORC components
- D VSET(INDA)
- D ORC1
- D ORC2
- D ORC3
- D ORC5
- D ORC10
- D ORC12
- D ORC17
- Q
- ;-----
- ORC1 ;
- S INA("ORC1",INDA)="RE"
- Q
- ;-----
- ORC2 ;
- ;PATCH 7 MAX LENGTH 15
- ;S INA("ORC2",INDA)=INDA_"-"_$P($G(^AUTTLOC($$DUZ^BYIMIMM(),0)),U,10)_CS_"IHS"
- S INA("ORC2",INDA)=$E(INDA_"-"_$P($G(^AUTTLOC($$DUZ^BYIMIMM(),0)),U,10),1,15)_CS_"IHS"
- Q
- ;-----
- ORC3 ;
- N X
- S X=$P($G(^AUPNVSIT(+$P($G(^AUPNVIMM(+INDA,0)),U,3),0)),".")
- ;PATCH 7 NOT MORE THAN 20 CHARACTERS
- S INA("ORC3",INDA)=$E($E($$TIMEIO^INHUT10(X),1,8)_"-"_INDA_"-"_$P($$HRN^BYIMIMM3($P($G(^AUPNVIMM(+INDA,0)),U,2)),U),1,20)_CS_$P($$HRN^BYIMIMM3($P($G(^AUPNVIMM(+INDA,0)),U,2)),U,4)
- ;PATCH 7
- S $P(INA("ORC3",INDA),U,2)=$E($P(INA("ORC3",INDA),U,2),1,20)
- Q
- ;-----
- ORC5 ;
- S INA("ORC5",INDA)="IP"
- Q
- ;-----
- ORC10 ;entered by
- N P,X,Y,Z
- S INA("ORC10",INDA)=""
- S P=+$P(X12,U,14)
- S:'P P=+$P(V0,U,23)
- Q:'P
- S X=$$PROV(P)
- S INA("ORC10",INDA)=X
- Q
- ;-----
- ORC12 ;ordering provider
- N P,X,Y,Z
- S INA("ORC12",INDA)=""
- S P=+$P(X12,U,2)
- S:'P P=+$P(X12,U,4)
- D:'P
- .S Y=+$P($G(^AUPNVIMM(+INDA,0)),U,3)
- .S P=+$O(^AUPNVPRV("AD",Y,0))
- .S P=+$G(^AUPNVPRV(P,0))
- Q:'P
- S X=$$PROV(P)
- S INA("ORC12",INDA)=X
- Q
- ;-----
- ORC17 ;setup for ORC17 variable - location
- ;PATCH 7
- ;S INA("ORC17",INDA)=CS_CS_CS_$P($G(^DIC(4,$$DUZ^BYIMIMM(),0)),U)
- ;S INA("ORC17",INDA)=$P($G(^AUTTLOC($$DUZ^BYIMIMM(),0)),U,10)_CS_$P($G(^DIC(4,$$DUZ^BYIMIMM(),0)),U)_CS_"RPMS"
- ;PATCH 8 CR 08611 - LIMIT NAME TO 20 CHARACTERS
- S INA("ORC17",INDA)=$P($G(^AUTTLOC($$DUZ^BYIMIMM(),0)),U,10)_CS_$E($P($G(^DIC(4,$$DUZ^BYIMIMM(),0)),U),1,20)_CS_"HL70396"
- ;PATCH 7 END
- ;PATCH 8 CR 08611 END
- ORCEND Q
- ;-----
- RXA ;EP;
- Q:'$D(^AUPNVIMM(INDA,0))
- D VSET(INDA)
- D RXA2
- D RXA3
- D RXA4
- D RXA5
- D RXA6
- D RXA7
- D RXA9
- D RXA10
- D RXA11
- D RXA15
- D RXA16
- D RXA17
- D RXA20
- D RXA21
- D RXA22
- Q
- ;-----
- RXA2 ;admin subid
- S INA("RXA2",INDA)=1
- Q
- ;-----
- RXA3 ;admin date/time
- S INA("RXA3",INDA)=$E($P($$TIMEIO^INHUT10($P(V0,U)),"-"),1,8)
- Q
- ;-----
- RXA4 ;date/time entered
- S INA("RXA4",INDA)=$E($P($$TIMEIO^INHUT10($P(V0,U)),"-"),1,8)
- Q
- ;-----
- RXA5 ;admin code
- N X
- I $G(Z1)="" S X=+$G(^AUPNVIMM(INDA,0)),Z1=$G(^AUTTIMM(X,1))
- S X=$P(Z0,U,3)
- S:$L(X)=1 X="0"_X
- S INA("RXA5",INDA)=X_CS_$P(Z0,U)_CS_"CVX"
- ;PATCH 8 CR 08781 - CPT CODE
- N CPT,CPT2,ICPT,X1,X2
- S CPT=$P(Z0,U,11)
- S CPT2=$P(Z1,U,15)
- ;N NDC
- ;S NDC=$P($G(^AUPNVIMM(INDA,0)),U,16)
- ;S:NDC NDC=$P($G(^BINDC(NDC,0)),U)
- ;Q:'CPT&'CPT2
- D:CPT2
- .S X1=$P($P(V0,U),".")
- .S X2=$P($G(^DPT(+$P(X0,U,2),0)),U,3)
- .D D^%DTC
- .S:X>1096 CPT=CPT2
- S:CPT INA("RXA5",INDA)=INA("RXA5",INDA)_"~"_CPT_CS_$P($G(^ICPT(CPT,0)),U,2)_CS_"CPT"
- ;S:NDC INA("RXA5",INDA)=INA("RXA5",INDA)_"~"_NDC_CS_NDC_CS_"NDC"
- ;PATCH 8 CR 08781 END
- Q
- ;-----
- RXA6 ;dose
- N X
- S X=+$P(X0,U,11)
- S:$E(X)="." X="0"_X
- ;PATCH 7 USE DEFAULT VOLUME WHEN NOT RECORDED
- ;PATCH 8 CR 08549 - DEFAULT VOLUME FOR MULTIPLE STATE FILES
- S:'X X=$P(Z0,U,18)
- S:'X X=$S($G(BYIMDVOL):BYIMDVOL,1:"")
- ;PATCH 8 CR 08549 END
- S INA("RXA6",INDA)=X
- Q
- ;-----
- RXA7 ;quantity definition
- S INA("RXA7",INDA)=""
- I INA("RXA6",INDA),INA("RXA6",INDA)'>997 S INA("RXA7",INDA)="ML^MilliLiters^ISO+"
- Q
- ;-----
- RXA9 ;admin history
- S INA("RXA9",INDA)=$$HX1^BYIMIMM3(INDA)_CS_$$HX2^BYIMIMM3(INDA)_CS_"NIP001"
- S:INA("RXA9",INDA) INA("RXA6",INDA)=999
- Q
- ;-----
- RXA10 ;encounter provider
- N X,Y,Z
- S INA("RXA10",INDA)=""
- S P=+$P(X12,U,4)
- D:'P
- .S Y=+$P($G(^AUPNVIMM(+INDA,0)),U,3)
- .S P=+$O(^AUPNVPRV("AD",Y,0))
- .S P=+$G(^AUPNVPRV(P,0))
- Q:'P
- S X=$$PROV(P)
- S INA("RXA10",INDA)=X
- Q
- ;-----
- RXA11 ;location of encounter
- S INA("RXA11",INDA)=""
- N X,Y,Z
- S Z=+$P(V0,U,6)
- I $D(^BYIMPARA($$DUZ^BYIMIMM(),5,Z,0)) S X=$P(^(0),U,2)
- I '$D(^BYIMPARA($$DUZ^BYIMIMM(),5,Z,0)) S X=$P($G(^DIC(4,Z,0)),U)
- I $E(X,1,5)="OTHER"!(X=""),$P(V21,U)]"" S X=$P(V21,U)
- ;PATCH 7 NOT MORE THAN 20 CHARACTERS
- S INA("RXA11",INDA)=CS_CS_CS_$E(X,1,20)
- Q
- ;-----
- RXA15 ;immunization lot number
- S INA("RXA15",INDA)=""
- N X,Y,Z
- S X=$P(X0,U,5)
- Q:'X
- S INA("RXA15",INDA)=$P($G(^AUTTIML(X,0)),U,16)
- S:INA("RXA15",INDA)="" INA("RXA15",INDA)=$P($G(^AUTTIML(X,0)),U)
- Q
- ;-----
- RXA16 ;immunization lot number
- S INA("RXA16",INDA)=""
- N X,Y,Z
- S X=+$P(X0,U,5)
- Q:'$P($G(^AUTTIML(X,0)),U,9)
- S INA("RXA16",INDA)=$P($G(^AUTTIML(X,0)),U,9)+17000000
- Q
- ;-----
- RXA17 ;immunization manufacturer
- S INA("RXA17",INDA)=""
- N X,Y,Z
- S X=$P(X0,U,5)
- Q:'X
- S X=$P($G(^AUTTIML(X,0)),U,2)
- Q:'X
- S X=$G(^AUTTIMAN(X,0))
- S INA("RXA17",INDA)=$P(X,U,2)_CS_$P(X,U)_CS_"MVX"
- Q
- ;-----
- RXA20 ;action code
- S INA("RXA20",INDA)="CP"
- Q
- ;-----
- RXA21 ;action code
- ;PATCH 6 DETERMINE WHETHER 'A' ADD OR 'U' UPDATE
- S INA("RXA21",INDA)="A"
- S:$D(^BYIMEXP("D",INDA)) INA("RXA21",INDA)="U"
- ;PATCH 6 DETERMINE WHETHER 'A' ADD OR 'U' UPDATE
- Q
- ;-----
- RXA22 ;action code
- S X=$P(X12,U,18)
- S:'X X=$P(X12,U)
- S:'X X=$P(V0,U)
- S INA("RXA22",INDA)=$E($P($$TIMEIO^INHUT10(X),"-"),1,8)
- RXAEND Q
- ;-----
- RXR ;EP;
- D RXR^BYIMSEG1
- Q
- ;-----
- QRD ;EP; setup the variables for the QRD segment
- N BYIMDA,BYIMNM,BYIMRN,BYIMASU
- S BYIMDA=$O(INA("QNM",0))
- Q:'BYIMDA
- D QRD1
- D QRD2
- D QRD3
- D QRD4
- D QRD7
- D QRD8
- D QRD9
- D QRD10
- D QRD12
- Q
- ;-----
- QRD1 ;
- D NOW^%DTC
- S INA("QRD1")=$P($$TIMEIO^INHUT10(%),"-")
- Q
- ;-----
- QRD2 ;
- S INA("QRD2")="R"
- Q
- ;-----
- QRD3 ;
- S INA("QRD3")="I"
- Q
- ;-----
- QRD4 ;
- S INA("QRD4")=INA("QRD1")_"-"_$P($$HRN^BYIMIMM3(BYIMDA),U)
- Q
- ;-----
- QRD7 ;
- S INA("QRD7")="25^RD"
- Q
- ;-----
- QRD8 ;information to build a who string (QRD-8)
- ;support for multiples built in
- N X,Y,Z
- S X=$P($G(^DPT(BYIMDA,0)),U)
- S X=$$PN^INHUT(X)
- S Y=$$HRN^BYIMIMM3(BYIMDA)
- S INA("QRD8")=$P(Y,U)_CS_X
- Q
- ;-----
- QRD9 ;
- S INA("QRD9")="VXI"_CS_"VACCINE INFORMATION"_CS_"HL70048"
- Q
- ;-----
- QRD10 ;
- S INA("QRD10")=CS_"IIS"
- Q
- ;-----
- QRD12 ;
- S INA("QRD12")="T"
- QRDEND Q
- ;-----
- FHS ;EP;
- D FHS3
- D MSH
- Q
- ;-----
- FHS3 ;
- N X
- S X=$P($G(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,7)
- S:X="" X=$P($G(^DIC(4,$$DUZ^BYIMIMM(),0)),U)
- S INA("FSH3")=X
- FHSEND Q
- ;-----
- RCP ;setup variables for RCP segment
- RCPEND Q
- ;-----
- QPD ;setup variables for QPD segment
- QPDEND Q
- ;-----
- VSET(INDA) ;SET VISIT VARIABLES
- S X0=^AUPNVIMM(INDA,0)
- S X12=$G(^AUPNVIMM(INDA,12))
- S Z0=$G(^AUTTIMM(+X0,0))
- ;PATCH 8 CR 08781 - INCLUDE GLOBAL NODE 1 FOR CPT2 CODE
- S Z1=$G(^AUTTIMM(+X0,1))
- ;PATCH 8 CR 08781 END
- S V0=$G(^AUPNVSIT(+$P(X0,U,3),0))
- S V21=$G(^AUPNVSIT(+$P(X0,U,3),21))
- S T=$P(V0,U,7)
- Q
- ;-----
- NPI(PRV) ;
- S NPI=$P($G(^VA(200,+PRV,"NPI")),U)
- Q NPI
- ;-----
- TITLE(P) ;GET PROVIDER'S TITLE/PROVIDER CLASS
- Q:'$G(P) ""
- N X,Y,Z
- S X=$P($G(^VA(200,P,"PS")),U,5)
- Q:'X ""
- S X=$P($G(^DIC(7,X,0)),U,2)
- Q X
- ;-----
- PROV(P) ;RETURN PROVIDER COMPONENT INFO
- ;PATCH 7 ADD PROV CALL TO ENSURE PROPER FORMAT
- N X,Y,Z
- S X=$P($G(^VA(200,P,0)),U)
- Q:X="" ""
- S TITLE=$$TITLE(P)
- S NPI=$$NPI(P)
- S Y=$P($P(X,",",2)," ")
- S Z=$P($P(X,",",2)," ",2)
- S X=NPI_CS_$P(X,",")_CS_Y_CS_Z_CS_CS_TITLE_CS_CS_CS_$S(NPI]"":"RPMS",1:"RPMS")_CS_"L"
- Q X
- ;
- BYIMSEGS ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
- +1 ;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22
- +2 ;
- +3 ;code to supplement fields in the HL7 segments
- +4 ;
- MSH ;EP;entry point
- +1 DO PATH^BYIMIMM6
- +2 DO NOW^%DTC
- +3 SET INA("EVDT")=%
- +4 SET INA("ENC")=$$COMP^INHUT()_$$REP^INHUT()_$$SUBCOMP^INHUT()_$$ESC^INHUT()
- +5 SET INA("MT")=$PIECE($GET(^INTHL7M(BHLMIEN,0)),U,6)
- +6 SET INA("ET")=$PIECE($GET(^INTHL7M(BHLMIEN,0)),U,2)
- +7 SET INA("ACA")=$PIECE($GET(^INTHL7M(BHLMIEN,0)),U,10)
- +8 SET INA("APA")=$PIECE($GET(^INTHL7M(BHLMIEN,0)),U,11)
- +9 SET INA("VER")=BYIMVER
- +10 SET INA("PRID")=$PIECE($GET(^INTHL7M(BHLMIEN,0)),U,3)
- +11 SET INA("SAP")=$PIECE($GET(^INTHL7M(BHLMIEN,7)),U)
- +12 SET INA("SF")=$PIECE($GET(^INTHL7M(BHLMIEN,7)),U,2)
- +13 SET INA("RAP")=$PIECE($GET(^INTHL7M(BHLMIEN,7)),U,3)
- +14 SET INA("RF")=$PIECE($GET(^INTHL7M(BHLMIEN,7)),U,4)
- +15 DO MSH3
- +16 DO MSH4
- +17 DO MSH5
- +18 DO MSH6
- +19 DO MSH7
- +20 DO MSH8
- +21 DO MSH9
- +22 DO MSH10
- +23 DO MSH11
- +24 DO MSH12
- +25 QUIT
- +26 ;-----
- MSH3 ;
- +1 SET X=BYIM("MSH3.1")
- +2 IF X=""
- SET X="RPMS"
- +3 IF BYIM("MSH3.2")]""
- SET X=X_CS_BYIM("MSH3.2")_CS_$SELECT($GET(BYIM("MSH3.3")):BYIM("MSH3.3"),1:"ISO")
- +4 SET INA("MSH3")=X
- +5 QUIT
- +6 ;-----
- MSH4 ;
- +1 NEW X
- +2 SET X=BYIM("MSH4.1")
- +3 IF X=""
- SET X=$PIECE($GET(^DIC(4,$$DUZ^BYIMIMM(),0)),U)
- +4 IF BYIM("MSH4.2")]""
- SET X=X_CS_BYIM("MSH4.2")_CS_$SELECT($GET(BYIM("MSH4.3")):BYIM("MSH4.3"),1:"ISO")
- +5 SET INA("MSH4")=X
- +6 QUIT
- +7 ;-----
- MSH5 ;
- +1 SET X=BYIM("MSH5.1")
- +2 IF BYIM("MSH5.2")]""
- SET X=X_CS_BYIM("MSH5.2")_CS_$SELECT($GET(BYIM("MSH5.3")):BYIM("MSH5.3"),1:"ISO")
- +3 SET INA("MSH5")=X
- +4 QUIT
- +5 ;-----
- MSH6 ;
- +1 SET INA("MSH6")=BYIM("MSH6")
- +2 QUIT
- +3 ;-----
- MSH7 ;
- +1 DO NOW^%DTC
- +2 SET INA("MSH7")=$PIECE($$TIMEIO^INHUT10(%),"-")
- +3 QUIT
- +4 ;-----
- MSH8 ;
- +1 SET INA("MSH8")=BYIMMSH8
- +2 QUIT
- +3 ;-----
- MSH9 ;
- +1 SET INA("MSH9")=INA("MT")_CS_INA("ET")_CS_INA("MT")_"_"_INA("ET")
- +2 QUIT
- +3 ;-----
- MSH10 ;
- +1 SET INA("MSH10")=$PIECE($GET(^INTHU(+$GET(UIF),0)),U,5)
- +2 IF INA("MSH10")=""
- SET INA("MSH10")=$$MESSID^INHD()
- +3 QUIT
- +4 ;-----
- MSH11 ;
- +1 SET INA("MSH11")="P"
- +2 QUIT
- +3 ;-----
- MSH12 ;
- +1 SET INA("MSH12")=BYIMVER
- +2 QUIT
- +3 ;-----
- MSHEND QUIT
- +1 ;-----
- PID ;EP;
- +1 DO PID3
- +2 DO PID5
- +3 DO PID6
- +4 DO PID7
- +5 DO PID10
- +6 DO PID11
- +7 DO PID13
- +8 DO PID14
- +9 DO PID19
- +10 DO PID22
- +11 DO PID24
- +12 QUIT
- +13 ;-----
- PID3 ;PID-3 HRN
- +1 NEW X,Y,Z
- +2 SET X=$$HRN^BYIMIMM3(INDA)
- +3 ;PATCH 8 CR 08549 - OVERRIDE SSN EXCLUSION FOR MULTIPLE STATE FILES
- +4 ;PATCH 6 ALLOW EXCLUSION OF SSN
- +5 ;I '$G(BYIMESSN) D
- +6 ;S Y=$TR($P($G(^DPT(INDA,0)),U,9),"-")
- +7 ;S:Y]"" X=X_"~"_Y_CS_CS_CS_"SSA"_CS_"SS"
- +8 ;PATCH 6 ALLOW EXCLUSION OF SSN
- +9 ;PATCH 8 CR 08549 END
- +10 SET Y=""
- +11 SET Z=$ORDER(^AUPNMCD("B",INDA,9999999999),-1)
- +12 IF Z
- SET Y=$PIECE($GET(^AUPNMCD(Z,0)),U,3)
- +13 IF Y]""
- SET X=X_"~"_Y_CS_CS_CS_"MCD"_CS_"MA"
- +14 ;PATCH 9 MEDICARE NUMBER
- +15 ;AUPN V99.1 PATCH 26 REQUIRED
- +16 SET Y=""
- +17 SET Y=$$GETMCR^AGUTL(INDA,DT)
- +18 IF $LENGTH(Y)
- SET X=X_"~"_Y_CS_CS_CS_"MEDICARE"_CS_"MC"
- +19 ;PATCH 9 END
- +20 SET INA("PID3")=X
- +21 SET INA("PID3",1)=X
- +22 QUIT
- +23 ;-----
- PID5 ;PID-5 NAME
- +1 NEW X,Y,Z
- +2 SET X=$PIECE($GET(^DPT(INDA,0)),U)
- +3 SET Y=$PIECE($PIECE(X,",",2)," ")
- +4 SET Z=$PIECE($PIECE(X,",",2)," ",2)
- +5 SET X=$PIECE(X,",")
- +6 SET INA("PID5")=X_CS_Y_CS_Z_CS_CS_CS_CS_"L"
- +7 SET INA("PID5",1)=INA("PID5")
- +8 QUIT
- +9 ;-----
- PID6 ;PID-6 MMN
- +1 NEW X,Y,Z
- +2 SET X=$PIECE($GET(^DPT(INDA,.24)),U,3)
- +3 SET Y=$PIECE($PIECE(X,",",2)," ")
- +4 SET Z=$PIECE($PIECE(X,",",2)," ",2)
- +5 SET X=$PIECE(X,",")
- +6 ;name type for MMN
- +7 SET INA("PID6")=$SELECT(X]"":(X_CS_Y_CS_Z_CS_CS_CS_CS_"M"),1:"")
- +8 SET INA("PID6",1)=INA("PID6")
- +9 QUIT
- +10 ;-----
- PID7 ;PID-7 DOB
- +1 SET INA("PID7")=17000000+$PIECE($GET(^DPT(INDA,0)),U,3)
- +2 SET INA("PID7",1)=INA("PID7")
- +3 QUIT
- +4 ;-----
- PID10 ;PID-10 RACE
- +1 SET INA("PID10")=$$RACE^BYIMIMM3(INDA)
- +2 SET INA("PID10",1)=INA("PID10")
- +3 QUIT
- +4 ;-----
- PID11 ;PID-11 ADDRESS
- +1 SET X=$GET(^DPT(+INDA,.11))
- +2 ;PATCH 8 CR 08631 - PATIENT ADDRESS TYPE
- +3 SET INA("PID11")=$PIECE(X,U)_CS_CS_$PIECE(X,U,4)_CS_$PIECE($GET(^DIC(5,+$PIECE(X,U,5),0)),U,2)_CS_$PIECE(X,U,6)_CS_"USA"_CS_$SELECT($GET(BYIMATYP)]"":BYIMATYP,1:"L")
- +4 ;PATCH 8 CR 08631 END
- +5 SET INA("PID11",1)=INA("PID11")
- +6 QUIT
- +7 ;-----
- PID13 ;PID-13 PHONE HOME
- +1 SET INA("PID13")=""
- +2 SET INA("PID13",1)=""
- +3 SET X=$PIECE($GET(^DPT(INDA,.13)),U)
- +4 SET X=$TRANSLATE(X,"()\/- ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
- +5 IF $EXTRACT(X)=1
- SET X=$EXTRACT(X,2,99)
- +6 IF X'?10N
- SET INA("PID13")=""
- +7 IF X?10N
- Begin DoDot:1
- +8 IF BYIMVER>2.4
- Begin DoDot:2
- +9 SET INA("PID13")=CS_"PRN"_CS_"PH"_CS_CS_CS_$EXTRACT(X,1,3)_CS_$EXTRACT(X,4,10)
- +10 SET INA("PID13",1)=INA("PID13")
- End DoDot:2
- +11 IF BYIMVER<2.5
- Begin DoDot:2
- +12 SET INA("PID13")="("_$EXTRACT(X,1,3)_")"_$EXTRACT(X,4,6)_"-"_$EXTRACT(X,7,10)_CS_"PRN"_CS_"PH"
- +13 SET INA("PID13",1)=INA("PID13")
- End DoDot:2
- End DoDot:1
- +14 SET X=$PIECE($GET(^AUPNPAT(INDA,18)),U,2)
- +15 IF X=""
- QUIT
- +16 SET X="~^NET^^"_X
- +17 SET INA("PID13")=INA("PID13")_X
- +18 SET INA("PID13",1)=INA("PID13")
- +19 QUIT
- +20 ;-----
- PID14 ;PID-14 PHONE BUSINESS
- +1 SET INA("PID14")=""
- +2 SET INA("PID14",1)=""
- +3 SET X=$PIECE($GET(^DPT(INDA,.13)),U,2)
- +4 SET X=$TRANSLATE(X,"()\/- ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
- +5 IF $EXTRACT(X)=1
- SET X=$EXTRACT(X,2,99)
- +6 IF X'?10N
- SET INA("PID14",1)=""
- QUIT
- +7 IF BYIMVER["2.5"
- Begin DoDot:1
- +8 SET INA("PID14")=CS_"WPN"_CS_"PH"_CS_CS_CS_$EXTRACT(X,1,3)_CS_$EXTRACT(X,4,10)
- +9 SET INA("PID14",1)=INA("PID14")
- End DoDot:1
- +10 IF BYIMVER'["2.5"
- Begin DoDot:1
- +11 SET INA("PID14")="("_$EXTRACT(X,1,3)_")"_$EXTRACT(X,4,6)_"-"_$EXTRACT(X,7,10)_CS_"WPN"_CS_"PH"
- +12 SET INA("PID14",1)=INA("PID14")
- End DoDot:1
- +13 QUIT
- +14 ;-----
- PID19 ;PID-19 SSN
- +1 SET Y=$TRANSLATE($PIECE($GET(^DPT(INDA,0)),U,9),"-")
- +2 IF Y]""
- SET X=Y_CS_CS_CS_"SSA"_CS_"SS"
- +3 ;S INA("PID19")=X
- +4 ;S INA("PID19",1)=X
- +5 QUIT
- +6 ;-----
- PID22 ;PID-22 ETHNICITY
- +1 SET INA("PID22")=$$ETH^BYIMIMM3(INDA)
- +2 SET INA("PID22",1)=INA("PID22")
- +3 QUIT
- +4 ;-----
- PID24 ;PID-24 BIRTH ORDER
- +1 SET INA("PID24")="N"
- +2 SET INA("PID24",1)="N"
- PIDEND QUIT
- +1 ;-----
- PD1 ;EP;
- +1 DO PD1^BYIMSEG1
- PD1END QUIT
- +1 ;-----
- NK1 ; generate the NK1 segment
- +1 DO NK11
- +2 DO NK12
- +3 DO NK13
- +4 DO NK14
- +5 DO NK15
- +6 DO NK17
- +7 QUIT
- +8 ;-----
- NK11 ;subid
- +1 SET INA("NK11")="1"
- +2 SET INA("NK11",1)="1"
- +3 QUIT
- +4 ;-----
- NK12 NEW X,FN,LN,MN
- +1 SET X=$PIECE($GET(^DPT(INDA,.21)),U)
- +2 SET LN=$PIECE(X,",")
- +3 SET FN=$PIECE($PIECE(X,",",2)," ")
- +4 SET MN=$PIECE($PIECE(X,",",2)," ",2)
- +5 ;PATCH 7 USE DEFAULT LN AND FN IF NOT DEFINED
- +6 IF LN=""
- SET LN="LAST_NAME"
- +7 IF FN=""
- SET FN="FIRST_NAME"
- +8 SET INA("NK12")=LN_CS_FN_CS_MN_CS_CS_CS_CS_"L"
- +9 SET INA("NK12",1)=INA("NK12")
- +10 QUIT
- +11 ;-----
- NK13 NEW X
- +1 SET X=+$PIECE($GET(^AUPNPAT(INDA,28)),U,2)
- +2 SET Y=$GET(^BYIMCDC(+$PIECE($GET(^BYIMREL(X,0)),U,2),0))
- +3 IF Y]""
- SET X=$PIECE(Y,U,2)
- SET Y=$PIECE(Y,U)
- +4 IF Y=""
- SET Y="OTH"
- SET X="OTHER"
- +5 SET INA("NK13")=Y_CS_X_CS_"HL70063"
- +6 SET INA("NK13",1)=INA("NK13")
- +7 QUIT
- +8 ;-----
- NK14 ;NOK ADDRESS
- +1 SET X=$PIECE($GET(^DPT(+INDA,.21)),U,3,8)
- +2 SET X=$PIECE(X,U)_CS_CS_$PIECE(X,U,4)_CS_$PIECE($GET(^DIC(5,+$PIECE(X,U,5),0)),U,2)_CS_$PIECE(X,U,6)_CS_"USA"_CS_"L"
- +3 SET INA("NK14")=X
- +4 SET INA("NK14",1)=X
- +5 QUIT
- +6 ;-----
- NK15 ;PHONE NUMBER
- +1 SET INA("NK15")=""
- +2 SET X=$PIECE($GET(^DPT(INDA,.21)),U,9)
- +3 SET X=$TRANSLATE(X,"()\/- ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
- +4 IF $EXTRACT(X)=1
- SET X=$EXTRACT(X,2,99)
- +5 IF X'?10N
- SET INA("NK15",1)=""
- QUIT
- +6 IF BYIMVER["2.5"
- Begin DoDot:1
- +7 SET INA("NK15")=CS_"PRN"_CS_"PH"_CS_CS_CS_$EXTRACT(X,1,3)_CS_$EXTRACT(X,4,10)
- +8 SET INA("NK15",1)=INA("NK15")
- End DoDot:1
- +9 IF BYIMVER'["2.5"
- Begin DoDot:1
- +10 SET INA("NK15")="("_$EXTRACT(X,1,3)_")"_$EXTRACT(X,4,6)_"-"_$EXTRACT(X,7,10)_CS_"PRN"_CS_"PH"
- +11 SET INA("NK15",1)=INA("NK15")
- End DoDot:1
- +12 QUIT
- +13 ;-----
- NK17 ;CONTACT
- +1 SET INA("NK17")="NOK^NEXT OF KIN"
- +2 SET INA("NK17",1)="NOK^NEXT OF KIN"
- +3 QUIT
- +4 ;-----
- NK1END QUIT
- +1 ;-----
- PV1 ;EP;FOR PV1 SEGMENT CONTENT
- +1 ;PATCH 7 ADD PV1 COMPONENT
- +2 DO PV11
- +3 DO PV12
- +4 DO PV13
- +5 DO PV17
- +6 DO PV19
- +7 DO PV119
- +8 DO PV120
- +9 DO PV144
- +10 QUIT
- +11 ;-----
- PV11 ;PV1-01
- +1 SET INA("PV11",1)=1
- +2 QUIT
- +3 ;-----
- PV12 ;PV1-02
- +1 SET INA("PV12",1)="R"
- +2 QUIT
- +3 ;-----
- PV13 ;PV1-03 PAT LOC
- +1 SET INA("PV13",1)=""
- +2 QUIT
- +3 ;-----
- PV17 ;PV1-07
- +1 SET INA("PV17",1)=""
- +2 SET P=$$PRIMPROV^APCLV(INDA,"I")
- +3 IF 'P
- QUIT
- +4 SET X=$$PROV(P)
- +5 SET INA("PV17",1)=X
- +6 QUIT
- +7 ;-----
- PV19 ;PV1-09
- +1 SET INA("PV19",1)=""
- +2 SET P=$$PRIMPROV^APCLV(INDA,"I")
- +3 IF 'P
- QUIT
- +4 SET X=$$PROV(P)
- +5 SET INA("PV19",1)=X
- +6 QUIT
- +7 ;-----
- PV119 ;PV1-19
- +1 ;PATCH 7
- +2 SET INA("PV119",1)=INDA_CS_CS_CS_"RPMS"_CS_"MR"
- +3 QUIT
- +4 ;-----
- PV120 ;PV1-20 VFC
- +1 SET INA("PV120",1)=$$VFC^BYIMIMM3(INDA)
- +2 QUIT
- +3 ;-----
- PV144 ;PV1-44 VISIT DATE
- +1 NEW X,Y,Z
- +2 SET INA("PV144",1)=""
- +3 SET X=$PIECE($GET(^AUPNVSIT(+$GET(INDA),0)),".")
- +4 IF $LENGTH(X)'=7
- QUIT
- +5 SET INA("PV144",1)=X+17000000
- PV1END QUIT
- +1 ;-----
- ORC ;EP; - for ORC components
- +1 DO VSET(INDA)
- +2 DO ORC1
- +3 DO ORC2
- +4 DO ORC3
- +5 DO ORC5
- +6 DO ORC10
- +7 DO ORC12
- +8 DO ORC17
- +9 QUIT
- +10 ;-----
- ORC1 ;
- +1 SET INA("ORC1",INDA)="RE"
- +2 QUIT
- +3 ;-----
- ORC2 ;
- +1 ;PATCH 7 MAX LENGTH 15
- +2 ;S INA("ORC2",INDA)=INDA_"-"_$P($G(^AUTTLOC($$DUZ^BYIMIMM(),0)),U,10)_CS_"IHS"
- +3 SET INA("ORC2",INDA)=$EXTRACT(INDA_"-"_$PIECE($GET(^AUTTLOC($$DUZ^BYIMIMM(),0)),U,10),1,15)_CS_"IHS"
- +4 QUIT
- +5 ;-----
- ORC3 ;
- +1 NEW X
- +2 SET X=$PIECE($GET(^AUPNVSIT(+$PIECE($GET(^AUPNVIMM(+INDA,0)),U,3),0)),".")
- +3 ;PATCH 7 NOT MORE THAN 20 CHARACTERS
- +4 SET INA("ORC3",INDA)=$EXTRACT($EXTRACT($$TIMEIO^INHUT10(X),1,8)_"-"_INDA_"-"_$PIECE($$HRN^BYIMIMM3($PIECE($GET(^AUPNVIMM(+INDA,0)),U,2)),U),1,20)_CS_$PIECE($$HRN^BYIMIMM3($PIECE($GET(^AUPNVIMM(+INDA,0)),U,2)),U,4)
- +5 ;PATCH 7
- +6 SET $PIECE(INA("ORC3",INDA),U,2)=$EXTRACT($PIECE(INA("ORC3",INDA),U,2),1,20)
- +7 QUIT
- +8 ;-----
- ORC5 ;
- +1 SET INA("ORC5",INDA)="IP"
- +2 QUIT
- +3 ;-----
- ORC10 ;entered by
- +1 NEW P,X,Y,Z
- +2 SET INA("ORC10",INDA)=""
- +3 SET P=+$PIECE(X12,U,14)
- +4 IF 'P
- SET P=+$PIECE(V0,U,23)
- +5 IF 'P
- QUIT
- +6 SET X=$$PROV(P)
- +7 SET INA("ORC10",INDA)=X
- +8 QUIT
- +9 ;-----
- ORC12 ;ordering provider
- +1 NEW P,X,Y,Z
- +2 SET INA("ORC12",INDA)=""
- +3 SET P=+$PIECE(X12,U,2)
- +4 IF 'P
- SET P=+$PIECE(X12,U,4)
- +5 IF 'P
- Begin DoDot:1
- +6 SET Y=+$PIECE($GET(^AUPNVIMM(+INDA,0)),U,3)
- +7 SET P=+$ORDER(^AUPNVPRV("AD",Y,0))
- +8 SET P=+$GET(^AUPNVPRV(P,0))
- End DoDot:1
- +9 IF 'P
- QUIT
- +10 SET X=$$PROV(P)
- +11 SET INA("ORC12",INDA)=X
- +12 QUIT
- +13 ;-----
- ORC17 ;setup for ORC17 variable - location
- +1 ;PATCH 7
- +2 ;S INA("ORC17",INDA)=CS_CS_CS_$P($G(^DIC(4,$$DUZ^BYIMIMM(),0)),U)
- +3 ;S INA("ORC17",INDA)=$P($G(^AUTTLOC($$DUZ^BYIMIMM(),0)),U,10)_CS_$P($G(^DIC(4,$$DUZ^BYIMIMM(),0)),U)_CS_"RPMS"
- +4 ;PATCH 8 CR 08611 - LIMIT NAME TO 20 CHARACTERS
- +5 SET INA("ORC17",INDA)=$PIECE($GET(^AUTTLOC($$DUZ^BYIMIMM(),0)),U,10)_CS_$EXTRACT($PIECE($GET(^DIC(4,$$DUZ^BYIMIMM(),0)),U),1,20)_CS_"HL70396"
- +6 ;PATCH 7 END
- +7 ;PATCH 8 CR 08611 END
- ORCEND QUIT
- +1 ;-----
- RXA ;EP;
- +1 IF '$DATA(^AUPNVIMM(INDA,0))
- QUIT
- +2 DO VSET(INDA)
- +3 DO RXA2
- +4 DO RXA3
- +5 DO RXA4
- +6 DO RXA5
- +7 DO RXA6
- +8 DO RXA7
- +9 DO RXA9
- +10 DO RXA10
- +11 DO RXA11
- +12 DO RXA15
- +13 DO RXA16
- +14 DO RXA17
- +15 DO RXA20
- +16 DO RXA21
- +17 DO RXA22
- +18 QUIT
- +19 ;-----
- RXA2 ;admin subid
- +1 SET INA("RXA2",INDA)=1
- +2 QUIT
- +3 ;-----
- RXA3 ;admin date/time
- +1 SET INA("RXA3",INDA)=$EXTRACT($PIECE($$TIMEIO^INHUT10($PIECE(V0,U)),"-"),1,8)
- +2 QUIT
- +3 ;-----
- RXA4 ;date/time entered
- +1 SET INA("RXA4",INDA)=$EXTRACT($PIECE($$TIMEIO^INHUT10($PIECE(V0,U)),"-"),1,8)
- +2 QUIT
- +3 ;-----
- RXA5 ;admin code
- +1 NEW X
- +2 IF $GET(Z1)=""
- SET X=+$GET(^AUPNVIMM(INDA,0))
- SET Z1=$GET(^AUTTIMM(X,1))
- +3 SET X=$PIECE(Z0,U,3)
- +4 IF $LENGTH(X)=1
- SET X="0"_X
- +5 SET INA("RXA5",INDA)=X_CS_$PIECE(Z0,U)_CS_"CVX"
- +6 ;PATCH 8 CR 08781 - CPT CODE
- +7 NEW CPT,CPT2,ICPT,X1,X2
- +8 SET CPT=$PIECE(Z0,U,11)
- +9 SET CPT2=$PIECE(Z1,U,15)
- +10 ;N NDC
- +11 ;S NDC=$P($G(^AUPNVIMM(INDA,0)),U,16)
- +12 ;S:NDC NDC=$P($G(^BINDC(NDC,0)),U)
- +13 ;Q:'CPT&'CPT2
- +14 IF CPT2
- Begin DoDot:1
- +15 SET X1=$PIECE($PIECE(V0,U),".")
- +16 SET X2=$PIECE($GET(^DPT(+$PIECE(X0,U,2),0)),U,3)
- +17 DO D^%DTC
- +18 IF X>1096
- SET CPT=CPT2
- End DoDot:1
- +19 IF CPT
- SET INA("RXA5",INDA)=INA("RXA5",INDA)_"~"_CPT_CS_$PIECE($GET(^ICPT(CPT,0)),U,2)_CS_"CPT"
- +20 ;S:NDC INA("RXA5",INDA)=INA("RXA5",INDA)_"~"_NDC_CS_NDC_CS_"NDC"
- +21 ;PATCH 8 CR 08781 END
- +22 QUIT
- +23 ;-----
- RXA6 ;dose
- +1 NEW X
- +2 SET X=+$PIECE(X0,U,11)
- +3 IF $EXTRACT(X)="."
- SET X="0"_X
- +4 ;PATCH 7 USE DEFAULT VOLUME WHEN NOT RECORDED
- +5 ;PATCH 8 CR 08549 - DEFAULT VOLUME FOR MULTIPLE STATE FILES
- +6 IF 'X
- SET X=$PIECE(Z0,U,18)
- +7 IF 'X
- SET X=$SELECT($GET(BYIMDVOL):BYIMDVOL,1:"")
- +8 ;PATCH 8 CR 08549 END
- +9 SET INA("RXA6",INDA)=X
- +10 QUIT
- +11 ;-----
- RXA7 ;quantity definition
- +1 SET INA("RXA7",INDA)=""
- +2 IF INA("RXA6",INDA)
- IF INA("RXA6",INDA)'>997
- SET INA("RXA7",INDA)="ML^MilliLiters^ISO+"
- +3 QUIT
- +4 ;-----
- RXA9 ;admin history
- +1 SET INA("RXA9",INDA)=$$HX1^BYIMIMM3(INDA)_CS_$$HX2^BYIMIMM3(INDA)_CS_"NIP001"
- +2 IF INA("RXA9",INDA)
- SET INA("RXA6",INDA)=999
- +3 QUIT
- +4 ;-----
- RXA10 ;encounter provider
- +1 NEW X,Y,Z
- +2 SET INA("RXA10",INDA)=""
- +3 SET P=+$PIECE(X12,U,4)
- +4 IF 'P
- Begin DoDot:1
- +5 SET Y=+$PIECE($GET(^AUPNVIMM(+INDA,0)),U,3)
- +6 SET P=+$ORDER(^AUPNVPRV("AD",Y,0))
- +7 SET P=+$GET(^AUPNVPRV(P,0))
- End DoDot:1
- +8 IF 'P
- QUIT
- +9 SET X=$$PROV(P)
- +10 SET INA("RXA10",INDA)=X
- +11 QUIT
- +12 ;-----
- RXA11 ;location of encounter
- +1 SET INA("RXA11",INDA)=""
- +2 NEW X,Y,Z
- +3 SET Z=+$PIECE(V0,U,6)
- +4 IF $DATA(^BYIMPARA($$DUZ^BYIMIMM(),5,Z,0))
- SET X=$PIECE(^(0),U,2)
- +5 IF '$DATA(^BYIMPARA($$DUZ^BYIMIMM(),5,Z,0))
- SET X=$PIECE($GET(^DIC(4,Z,0)),U)
- +6 IF $EXTRACT(X,1,5)="OTHER"!(X="")
- IF $PIECE(V21,U)]""
- SET X=$PIECE(V21,U)
- +7 ;PATCH 7 NOT MORE THAN 20 CHARACTERS
- +8 SET INA("RXA11",INDA)=CS_CS_CS_$EXTRACT(X,1,20)
- +9 QUIT
- +10 ;-----
- RXA15 ;immunization lot number
- +1 SET INA("RXA15",INDA)=""
- +2 NEW X,Y,Z
- +3 SET X=$PIECE(X0,U,5)
- +4 IF 'X
- QUIT
- +5 SET INA("RXA15",INDA)=$PIECE($GET(^AUTTIML(X,0)),U,16)
- +6 IF INA("RXA15",INDA)=""
- SET INA("RXA15",INDA)=$PIECE($GET(^AUTTIML(X,0)),U)
- +7 QUIT
- +8 ;-----
- RXA16 ;immunization lot number
- +1 SET INA("RXA16",INDA)=""
- +2 NEW X,Y,Z
- +3 SET X=+$PIECE(X0,U,5)
- +4 IF '$PIECE($GET(^AUTTIML(X,0)),U,9)
- QUIT
- +5 SET INA("RXA16",INDA)=$PIECE($GET(^AUTTIML(X,0)),U,9)+17000000
- +6 QUIT
- +7 ;-----
- RXA17 ;immunization manufacturer
- +1 SET INA("RXA17",INDA)=""
- +2 NEW X,Y,Z
- +3 SET X=$PIECE(X0,U,5)
- +4 IF 'X
- QUIT
- +5 SET X=$PIECE($GET(^AUTTIML(X,0)),U,2)
- +6 IF 'X
- QUIT
- +7 SET X=$GET(^AUTTIMAN(X,0))
- +8 SET INA("RXA17",INDA)=$PIECE(X,U,2)_CS_$PIECE(X,U)_CS_"MVX"
- +9 QUIT
- +10 ;-----
- RXA20 ;action code
- +1 SET INA("RXA20",INDA)="CP"
- +2 QUIT
- +3 ;-----
- RXA21 ;action code
- +1 ;PATCH 6 DETERMINE WHETHER 'A' ADD OR 'U' UPDATE
- +2 SET INA("RXA21",INDA)="A"
- +3 IF $DATA(^BYIMEXP("D",INDA))
- SET INA("RXA21",INDA)="U"
- +4 ;PATCH 6 DETERMINE WHETHER 'A' ADD OR 'U' UPDATE
- +5 QUIT
- +6 ;-----
- RXA22 ;action code
- +1 SET X=$PIECE(X12,U,18)
- +2 IF 'X
- SET X=$PIECE(X12,U)
- +3 IF 'X
- SET X=$PIECE(V0,U)
- +4 SET INA("RXA22",INDA)=$EXTRACT($PIECE($$TIMEIO^INHUT10(X),"-"),1,8)
- RXAEND QUIT
- +1 ;-----
- RXR ;EP;
- +1 DO RXR^BYIMSEG1
- +2 QUIT
- +3 ;-----
- QRD ;EP; setup the variables for the QRD segment
- +1 NEW BYIMDA,BYIMNM,BYIMRN,BYIMASU
- +2 SET BYIMDA=$ORDER(INA("QNM",0))
- +3 IF 'BYIMDA
- QUIT
- +4 DO QRD1
- +5 DO QRD2
- +6 DO QRD3
- +7 DO QRD4
- +8 DO QRD7
- +9 DO QRD8
- +10 DO QRD9
- +11 DO QRD10
- +12 DO QRD12
- +13 QUIT
- +14 ;-----
- QRD1 ;
- +1 DO NOW^%DTC
- +2 SET INA("QRD1")=$PIECE($$TIMEIO^INHUT10(%),"-")
- +3 QUIT
- +4 ;-----
- QRD2 ;
- +1 SET INA("QRD2")="R"
- +2 QUIT
- +3 ;-----
- QRD3 ;
- +1 SET INA("QRD3")="I"
- +2 QUIT
- +3 ;-----
- QRD4 ;
- +1 SET INA("QRD4")=INA("QRD1")_"-"_$PIECE($$HRN^BYIMIMM3(BYIMDA),U)
- +2 QUIT
- +3 ;-----
- QRD7 ;
- +1 SET INA("QRD7")="25^RD"
- +2 QUIT
- +3 ;-----
- QRD8 ;information to build a who string (QRD-8)
- +1 ;support for multiples built in
- +2 NEW X,Y,Z
- +3 SET X=$PIECE($GET(^DPT(BYIMDA,0)),U)
- +4 SET X=$$PN^INHUT(X)
- +5 SET Y=$$HRN^BYIMIMM3(BYIMDA)
- +6 SET INA("QRD8")=$PIECE(Y,U)_CS_X
- +7 QUIT
- +8 ;-----
- QRD9 ;
- +1 SET INA("QRD9")="VXI"_CS_"VACCINE INFORMATION"_CS_"HL70048"
- +2 QUIT
- +3 ;-----
- QRD10 ;
- +1 SET INA("QRD10")=CS_"IIS"
- +2 QUIT
- +3 ;-----
- QRD12 ;
- +1 SET INA("QRD12")="T"
- QRDEND QUIT
- +1 ;-----
- FHS ;EP;
- +1 DO FHS3
- +2 DO MSH
- +3 QUIT
- +4 ;-----
- FHS3 ;
- +1 NEW X
- +2 SET X=$PIECE($GET(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,7)
- +3 IF X=""
- SET X=$PIECE($GET(^DIC(4,$$DUZ^BYIMIMM(),0)),U)
- +4 SET INA("FSH3")=X
- FHSEND QUIT
- +1 ;-----
- RCP ;setup variables for RCP segment
- RCPEND QUIT
- +1 ;-----
- QPD ;setup variables for QPD segment
- QPDEND QUIT
- +1 ;-----
- VSET(INDA) ;SET VISIT VARIABLES
- +1 SET X0=^AUPNVIMM(INDA,0)
- +2 SET X12=$GET(^AUPNVIMM(INDA,12))
- +3 SET Z0=$GET(^AUTTIMM(+X0,0))
- +4 ;PATCH 8 CR 08781 - INCLUDE GLOBAL NODE 1 FOR CPT2 CODE
- +5 SET Z1=$GET(^AUTTIMM(+X0,1))
- +6 ;PATCH 8 CR 08781 END
- +7 SET V0=$GET(^AUPNVSIT(+$PIECE(X0,U,3),0))
- +8 SET V21=$GET(^AUPNVSIT(+$PIECE(X0,U,3),21))
- +9 SET T=$PIECE(V0,U,7)
- +10 QUIT
- +11 ;-----
- NPI(PRV) ;
- +1 SET NPI=$PIECE($GET(^VA(200,+PRV,"NPI")),U)
- +2 QUIT NPI
- +3 ;-----
- TITLE(P) ;GET PROVIDER'S TITLE/PROVIDER CLASS
- +1 IF '$GET(P)
- QUIT ""
- +2 NEW X,Y,Z
- +3 SET X=$PIECE($GET(^VA(200,P,"PS")),U,5)
- +4 IF 'X
- QUIT ""
- +5 SET X=$PIECE($GET(^DIC(7,X,0)),U,2)
- +6 QUIT X
- +7 ;-----
- PROV(P) ;RETURN PROVIDER COMPONENT INFO
- +1 ;PATCH 7 ADD PROV CALL TO ENSURE PROPER FORMAT
- +2 NEW X,Y,Z
- +3 SET X=$PIECE($GET(^VA(200,P,0)),U)
- +4 IF X=""
- QUIT ""
- +5 SET TITLE=$$TITLE(P)
- +6 SET NPI=$$NPI(P)
- +7 SET Y=$PIECE($PIECE(X,",",2)," ")
- +8 SET Z=$PIECE($PIECE(X,",",2)," ",2)
- +9 SET X=NPI_CS_$PIECE(X,",")_CS_Y_CS_Z_CS_CS_TITLE_CS_CS_CS_$SELECT(NPI]"":"RPMS",1:"RPMS")_CS_"L"
- +10 QUIT X
- +11 ;
