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 ;
