BYIMSEG1 ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22
;
;this routine will contain code to supplement fields in the
;HL7 segments
;
IN1MCARE ;MEDICARE IN1 SEGMENTS
;PATCH 9 NMCI CHANGE MCR NUMBER
S INDA(1)=INDA
D IN1MCR17
D IN1MCR49
;PATCH 9 END
Q
;-----
IN1MCR17 ;
S X="SEL^SELF^HL70063"
S INA("IN1MCR17")=X
S INA("IN1MCR17",1)=X
S INA("IN1MCR17",INDA)=X
S INA("IN1MCR17",INDA,1)=X
S INA("IN1MCR17",9000003,INDA)=X
S INA("IN1MCR17",9000003,INDA,1)=X
Q
;-----
IN1MCR49 ;
;AUPN V99.1 PATCH 26 REQUIRED
S X=$$GETMCR^AGUTL(INDA,DT)
S INA("IN1MCR49")=X
S INA("IN1MCR49",1)=X
S INA("IN1MCR49",INDA)=X
S INA("IN1MCR49",INDA,1)=X
S INA("IN1MCR49",9000003,INDA)=X
S INA("IN1MCR49",9000003,INDA,1)=X
Q
;-----
IN1RRE ;RAILROAD IN1 SEGMENTS
;PATCH 9 NMCI CHANGE MCR NUMBER
;AUPN V99.1 PATCH 26 REQUIRED
S INDA(1)=INDA
D IN1RRE49
;PATCH 9 END
Q
;-----
IN1RRE49 ;
;AUPN V99.1 PATCH 26 REQUIRED
S X=$$GETRRE^AGUTL(INDA,DT)
S INA("IN1RRE49")=X
S INA("IN1RRE49",1)=X
S INA("IN1RRE49",INDA)=X
S INA("IN1RRE49",INDA,1)=X
S INA("IN1RRE49",9000003,INDA)=X
S INA("IN1RRE49",9000003,INDA,1)=X
Q
;-----
OBXCE ;EP;
D VSET^BYIMSEGS(INDA)
D OBXCE1
D OBXCE2
D OBXCE3
D OBXCE4
D OBXCE5
D OBXCE11
D OBXCE14
D OBXCE17
Q
;-----
OBXCE1 ;subid
S INA("OBXCE1",INDA)="1"
Q
;-----
OBXCE2 ;vt
S INA("OBXCE2",INDA)="CE"
Q
;-----
OBXCE3 ;od
S INA("OBXCE3",INDA)="64994-7"_CS_"funding eligibility for immunization"_CS_"LN"
Q
;-----
OBXCE4 ;osid
S INA("OBXCE4",INDA)="1"
Q
;-----
OBXCE5 ;ov
S INA("OBXCE5",INDA)=$$IVFC^BYIMIMM3(INDA)
Q
;-----
OBXCE11 ;abn
S INA("OBXCE11",INDA)="F"
Q
;-----
OBXCE14 ;edt
S INA("OBXCE14",INDA)=""
N X
S X=$P(X12,U)
S:'X X=$P(V0,U)
Q:'X
S INA("OBXCE14",INDA)=$E($$TIMEIO^INHUT10(X),1,8)
Q
;-----
OBXCE17 ;METHOD OF CAPTURE
S INA("OBXCE17",INDA)="VXC40"_CS_"per immunization"_CS_"CDCPHINVS"
OBXCEEND Q
;-----
;-----
OBXPR ;EP;VIS PRESENTED
D VSET^BYIMSEGS(INDA)
D OBXPR1
D OBXPR2
D OBXPR3
D OBXPR4
D OBXPR5
Q
;-----
OBXPR1 ;subid
S INA("OBXPR1",INDA)="5"
Q
;-----
OBXPR2 ;vt
S INA("OBXPR2",INDA)="TS"
Q
;-----
OBXPR3 ;od
S INA("OBXPR3",INDA)="29769-7"_CS_"Date vaccine information statement presented"_CS_"LN"
Q
;-----
OBXPR4 ;osid
S INA("OBXPR4",INDA)="2"
Q
;-----
OBXPR5 ;ov
N X
S X=""
S INA("OBXPR5",INDA)=""
S X=$P(V0,".")
S:X X=X+17000000
S INA("OBXPR5",INDA)=X
OBXPREND Q
;-----
;-----
OBXPB ;EP;VIS PUBLISHED
D VSET^BYIMSEGS(INDA)
D OBXPB1
D OBXPB2
D OBXPB3
D OBXPB4
D OBXPB5
Q
;-----
OBXPB1 ;subid
S INA("OBXPB1",INDA)="4"
Q
;-----
OBXPB2 ;vt
S INA("OBXPB2",INDA)="TS"
Q
;-----
OBXPB3 ;od
S INA("OBXPB3",INDA)="29768-9"_CS_"Date vaccine information statement published"_CS_"LN"
Q
;-----
OBXPB4 ;osid
S INA("OBXPB4",INDA)="2"
Q
;-----
OBXPB5 ;ov
N X,Y,Z
S PUB=""
S INA("OBXPB5",INDA)=""
D PUB(X0)
S:$L(PUB)=7 INA("OBXPB5",INDA)=PUB+17000000
OBXPBEND Q
;-----
;-----
REFUSAL(DFN,UIF) ;EP;TO CREATE REFUSAL RELATED SEGMENTS
;DFN = PATIENT DFN
;UIF = IEN FOR ^INTHU
Q:'$G(UIF)
D:$G(DFN) R1(DFN,UIF)
D:$G(DFN) V1(DFN,UIF)
D COMP(UIF)
Q
;-----
R1(DFN,UIF) ;EP;FIND PATIENT RELATED REFUSALS
;DFN = PATIENT DFN
;UIF = IEN FOR ^INTHU
;N X,Y,Z
;PATCH 7 - CHANGE VARIABLE 'X' TO 'REFX'
N REFX,Y,Z
S INDA=$O(INA("ORC1",9999999999),-1)
S REFX=0
F S REFX=$O(^AUPNPREF("AC",DFN,REFX)) Q:'REFX S X0=$G(^AUPNPREF(REFX,0)) D:+X0=3
.;PATCH 7 EXPAND QUIT LOGIC SO DOES NOT QUIT IF 'ALL' IMM'S
.;Q:$D(^BYIMEXP("REF",REFX))
.I $G(^BYIMEXP("REF",REFX)),$G(BYIMALL)'=2 Q
.Q:'$P(X0,U,6)
.Q:'$D(^AUTTIMM($P(X0,U,6),0))
.S INDA=INDA+1
.S Y="ORC|RE||9999^CDC|CR|"
.S LCT=+$O(^INTHU(UIF,3,9999999999),-1)+1
.S ^INTHU(UIF,3,LCT,0)=Y
.S V0=$P(X0,U,3)
.N CS
.S CS=U
.;PATCH 7 GET PAT REFUSAL DATE DIRECTLY
.S INA("RXA3",INDA)=$P($G(^AUPNPREF(REFX,0)),U,3)
.S:INA("RXA3",INDA)]"" INA("RXA3",INDA)=INA("RXA3",INDA)+17000000
.;D RXA3^BYIMSEGS
.;END CHANGE
.N IZDA
.S IZDA=+$P(X0,U,6)
.I '$D(^AUTTIMM(IZDA,0)) S IZDA=$P(X0,U,4) S:IZDA]"" IZDA=+$O(^AUTTIMM("B",IZDA,0))
.S Z0=$G(^AUTTIMM(IZDA,0))
.D RXA5^BYIMSEGS
.S Z=$S($P($G(^DPT(DFN,0)),U,3)<(DT-180000):"03^Patient decision",1:"00^Parental decision")_CS_"NIP002"
.S LCT=+$O(^INTHU(UIF,3,9999999999),-1)+1
.S ^INTHU(UIF,3,LCT,0)="RXA|0|1|"_INA("RXA3",INDA)_"||"_INA("RXA5",INDA)_"|999|||01^HISTORICAL INFORMATION - SOURCE UNSPECIFIED^NIP001|||||||||"_Z_"||RE|CR|"
.;PATCH 7 ADD IIS ID CODE FOR REFUSALS IF AVAILABLE
.S X=$P($G(^BYIMPARA($$DUZ^BYIMIMM(),5,$$DUZ^BYIMIMM(),0)),U,2)
.S:X="" X=$E($P($G(^DIC(4,+$G(^AUTTSITE(1,0)),0)),U),1,20)
.S X="^^^"_X
.S $P(^INTHU(UIF,3,LCT,0),"|",12)=X
.S:'$G(BYIMMU2)&'$G(BYIMTEST) ^BYIMEXP("REF",REFX)=DT
Q
;-----
V1(DFN,UIF) ;EP;DETERMINE VARICELLA EXPOSURE
;DFN = PATIENT DFN
;UIF = IEN FOR ^INTHU
Q:'$D(^BIPC("B",+DFN))
N VDAT,BIX,LCT,ORC,RXA,OBX
S VDAT=""
S BIX=0
F S BIX=$O(^BIPC("B",DFN,BIX)) Q:'BIX D:$P($G(^BIPC(BIX,0)),U,2)
.I $G(^BYIMEXP("HXV",BIX)),$G(BYIMALL)'=2 Q
.;PATCH 7
.;FILTER OUT NON-CONTRAINDICATION ENTRIES
.Q:"^11^13^16^17^18^"[(U_$P($G(^BIPC(BIX,0)),U,3)_U)
.S IMM=$P($G(^BIPC(BIX,0)),U,2)
.S VDAT=$P(^BIPC(BIX,0),U,4)
.Q:$L(VDAT)'=7
.S:'$G(BYIMMU2) ^BYIMEXP("HXV",BIX)=VDAT
.S LCT=+$O(^INTHU(UIF,3,9999999999),-1)+1
.S VDAT=VDAT+17000000
.S ORC="ORC|RE||9999^CDC|CR|"
.S RXA="RXA|0|1|"_VDAT_"|"_VDAT_"|998^No vaccine administered^CVX|999|"
.S $P(RXA,"|",21)="NA|CR|"
.N X
.S X=$G(^BYIMCON(IMM,0))
.I X="" S OBX="OBX|1|CE|30945-0^Vaccination contraindication/precaution^LN|1|00000000^Reason not recorded^SCT||||||F|CR|"
.I X]"" S OBX="OBX|1|CE|30945-0^Vaccination contraindication/precaution^LN|1|"_$P(X,U,2)_U_$P(X,U,3)_"^SCT||||||F|CR|"
.S ^INTHU(UIF,3,LCT,0)=ORC
.S LCT=+$O(^INTHU(UIF,3,9999999999),-1)+1
.S ^INTHU(UIF,3,LCT,0)=RXA
.S LCT=+$O(^INTHU(UIF,3,9999999999),-1)+1
.S ^INTHU(UIF,3,LCT,0)=OBX
Q
;-----
COMP(UIF) ;EP;REFORMAT MESSAGE PRIOR TO TRANSMISSION
;UIF = IEN FOR ^INTHU
N X,Y,Z,CNT
K ^BYIMTMP("UIF",UIF)
S CNT=0
S XX=0
F S XX=$O(^INTHU(UIF,3,XX)) Q:'XX S X=^(XX,0) D
.S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
.S ^BYIMTMP("UIF",UIF,3,CNT,0)=X
.Q:X'["ORC|"!($E(X,1,4)'?3U1"|")
.D NORC(UIF)
.D EVAL(UIF)
K ^INTHU(UIF,3)
S X=0
F S X=$O(^BYIMTMP("UIF",UIF,3,X)) Q:'X S Y=^(X,0) S:Y]"" ^INTHU(UIF,3,X,0)=Y
K ^BYIMTMP("UIF",UIF)
Q
;-----
;-----
NORC(UIF) ;FIND NEXT ORC
N X,Y,Z
S J=XX+1
S X=XX
F S X=$O(^INTHU(UIF,3,X)) Q:'X I ^(X,0)["ORC|" S XX=X-1 Q
S:J>XX XX=$O(^INTHU(UIF,3,9999999999),-1)
Q
;-----
EVAL(UIF) ;EVAL FOR MULTIPLE VACCINE RXA'S
N X,Y,Z,HIST,CNT,RXA,CVX,CVXDA,NAM,OBXPR,OBXPU
S RXA=""
S OBXPR=""
S OBXPU=""
S HIST=0
F J=J:1:XX D
.S X2="",X=$G(^INTHU(UIF,3,J,0))
.I X'["|CR|",$G(^INTHU(UIF,3,J+1,0))["|CR|" S X2=^(0),J=J+1
.S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
.D:$E(X,1,4)="RXA|"
..S RXA=X
..S HIST=+$P(RXA,"|",10)
.I 'HIST,X'["vaccine info" D
..S ^BYIMTMP("UIF",UIF,3,CNT,0)=X
..S:X2]"" CNT=CNT+1,^BYIMTMP("UIF",UIF,3,CNT,0)=X2,X2=""
.I HIST,"|MSH|PID|ORC|RXA|"[("|"_$E(X,1,3)_"|") D
..S ^BYIMTMP("UIF",UIF,3,CNT,0)=X
..S:X2]"" CNT=CNT+1,^BYIMTMP("UIF",UIF,3,CNT,0)=X2,X2=""
.S:X["present" OBXPR=$G(^INTHU(UIF,3,J,0))
.S:X["publish" OBXPU=$G(^INTHU(UIF,3,J,0))
Q:RXA=""
Q:HIST
Q:$P(RXA,"|",19)]""
S CVX=+$P(RXA,"|",6)
S CVXDA=+$O(^AUTTIMM("C",CVX,0))
S X=$G(^AUTTIMM(CVXDA,0))
;PATCH 7 GET DIRECT PUB DATE
N ORPUB
S ORPUB=$P(X,U,13)
S CMP=$P($G(^AUTTIMM(CVXDA,0)),U,21,26)
I $L(CMP)>5 D E1(RXA,CMP) Q
S:$P($G(^BYIMNOS(CVXDA,0)),U,2) X=$G(^AUTTIMM(+$P(^(0),U,2),0))
S NAM=$P(X,U)
S CVX=+$P(X,U,3)
S CVXDA=+$O(^AUTTIMM("C",CVX,0))
S PUB=$P(X,U,13)
S:'PUB PUB=$P($G(^BYIMNOS(CVXDA,0)),U,3)
;PATCH 7 USE DIRECT PUB DATE IF NOT GENERIC DEFAULT
S:'PUB PUB=ORPUB
D:$G(OBXPU)]""
.S $P(OBXPU,"|",6)=PUB+17000000
.S:OBXPU'["|CR|" OBXPU=OBXPU_"|CR|"
.S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
.S ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPU
D:$G(OBXPR)]""
.S:OBXPR'["|CR|" OBXPR=OBXPR_"|CR|"
.S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
.S ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPR
Q
;-----
E1(RXA,CMP) ;
N J,K,L,X,Y,Z,XX
S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)
S X=$G(^BYIMTMP("UIF",UIF,3,CNT,0))
I $E(X,1,9)="OBX|3|CE|" K ^BYIMTMP("UIF",UIF,3,CNT)
S K=2
S L=1
F J=1:1:6 S X=$P(CMP,U,J) D:X
.S:$P($G(^BYIMNOS(X,0)),U,2) X=$P(^(0),U,2),NOSPUB=$P(^(0),U,3)
.S X=$G(^AUTTIMM(X,0))
.S NAM=$P(X,U)
.S CVX=$P(X,U,3)
.S PUB=$P(X,U,13)
.I 'PUB,NOSPUB S PUB=NOSPUB
.S K=K+1
.S L=L+1
.S X="OBX|"_K_"|"
.S $P(X,"|",3)="CE"
.S $P(X,"|",4)="30956-7"_U_"vaccine type"_U_"LN"
.S $P(X,"|",5)=L
.S $P(X,"|",6)=(CVX_U_NAM_U_"CVX")
.S $P(X,"|",12)="F"
.S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
.S ^BYIMTMP("UIF",UIF,3,CNT,0)=X_"|CR|"
.S K=K+1
.S $P(OBXPU,"|",2)=K
.S $P(OBXPU,"|",5)=L
.S $P(OBXPU,"|",6)=PUB+17000000
.S $P(OBXPU,"|",12)="F"
.S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
.S ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPU
.S K=K+1
.S $P(OBXPR,"|",2)=K
.S $P(OBXPR,"|",5)=L
.S $P(OBXPR,"|",12)="F"
.S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
.S ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPR
Q
;-----
;-----
OBXTY ;EP;
D VSET^BYIMSEGS(INDA)
D OBXTY1
D OBXTY2
D OBXTY3
D OBXTY4
D OBXTY5
D OBXTY11
Q
;-----
OBXTY1 ;subid
S INA("OBXTY1",INDA)="3"
Q
;-----
OBXTY2 ;vt
S INA("OBXTY2",INDA)="CE"
Q
;-----
OBXTY3 ;od
S INA("OBXTY3",INDA)="30956-7"_CS_"vaccine type"_CS_"LN"
Q
;-----
OBXTY4 ;osid
S INA("OBXTY4",INDA)="2"
Q
;-----
OBXTY5 ;ov
N X
S CVX=$P(Z0,U,3)
S IDA=+$O(^AUTTIMM("C",+CVX,0))
S:$P($G(^BYIMNOS(IDA,0)),U,2) IDA=$P(^(0),U,2)
S X=$G(^AUTTIMM(IDA,0))
S CVX=$P(X,U,3)
S:$L(CVX)=1 CVX="0"_CVX
S INA("OBXTY5",INDA)=CVX_CS_$P(X,U)_CS_"CVX"
Q
;-----
OBXTY11 ;abn
S INA("OBXTY11",INDA)="F"
Q
;-----
OBXTYEND Q
;-----
;-----
QRF ;EP;main QRF routine driver
S INA("INQWHICH")="ANY"
D QRF1
D QRF2
D QRF3
D QRF5
Q
;-----
QRF1 ;
S INA("QRF1")=$P($G(^DIC(4,$$DUZ^BYIMIMM(),0)),U)
Q
QRF2 ;
S INA("QRF2")=""
Q
;-----
QRF3 ;
;S INA("INQEDTM")=$G(INA("QEDT"))
S INA("QRF3")=""
Q
;-----
QRF5 ;build the other query subject filter
N BYIMDA,BYIMSSN,BYIMDOB,BYIMBST,BYIMBCN,BYIMMCN,BYIMMNM,BYIMMMN,BYIMMSSN,BYIMFNM
S BYIMDA=$O(INA("QNM",0))
Q:'BYIMDA
N X,Y,Z,X0,X24
S X0=$G(^DPT(BYIMDA,0))
Q:X0=""
S BYIMSSN=$TR($P(X0,U,9),"-")
S BYIMDOB=$P(X0,U,3)+17000000
S BYIMBST=$P($G(^DIC(5,+$P(X0,U,12),0)),U,2)
S BYIMBCN=$P($G(^AUPNPAT(BYIMDA,11)),U,5)
S BYIMMCN=""
S BYIMMNM=""
S BYIMMMN=""
S BYIMMSSN=""
S BYIMFNM=""
S X24=$G(^DPT(BYIMDA,.24))
S X=$P(X24,U,2)
S:X]"" BYIMMNM=$$QRFNAME(X)
S X=$P(X24,U,3)
S:X]"" BYIMMMN=$$QRFNAME(X)
S X=$P(X24,U)
S:X]"" BYIMFNM=$$QRFNAME(X)
S BYIMFSSN=""
S INA("QRF5")=BYIMSSN_RS_BYIMDOB_RS_BYIMBST_RS_BYIMBCN_RS_BYIMMCN_RS_BYIMMNM_RS_BYIMMMN_RS_BYIMMSSN_RS_BYIMFNM_RS_BYIMFSSN
Q
;-----
QRFNAME(NAME) ;FORMAT NAME
Q:NAME="" ""
S X=$P(NAME,",")_U_$P($P(NAME,",",2)," ")
S:NAME[" " X=X_U_$P(NAME," ",2)
Q X
QRFEND Q
;-----
;-----
FHS ;EP;
Q
;-----
PUB(X0) ;FIND PUB DATE
S PUB=$P(X0,U,12)
Q:$L(PUB)=7
S IDA=+X0
Q:'IDA
S BYIMNOS=$G(^BYIMNOS(IDA,0))
;PATCH 7 GET DIRECT PUB DATE IF NOS NOT DEFINED
;Q:'BYIMNOS
I 'BYIMNOS S PUB=$P($G(^AUTTIMM(IDA,0)),U,13) Q
S NOSDA=+$P(BYIMNOS,U,2)
S PUB=$P(BYIMNOS,U,3)
;S:NOSDA=IDA PUB=$P(X0,U,12)
I 'PUB,NOSDA S PUB=$P($G(^AUTTIMM(NOSDA,0)),U,13)
;I 'PUB,NOSPUB S PUB=NOSPUB
Q
OBXFS ;EP;
;PATCH 6 TO INCLUDE FUNDING SOURCE OBX SEGMENT
D VSET^BYIMSEGS(INDA)
D OBXFS1
D OBXFS2
D OBXFS3
D OBXFS4
D OBXFS5
D OBXFS11
D OBXFS14
Q
;-----
OBXFS1 ;subid
S INA("OBXFS1",INDA)="2"
Q
;-----
OBXFS2 ;vt
S INA("OBXFS2",INDA)="CE"
Q
;-----
OBXFS3 ;od
S INA("OBXFS3",INDA)="30963-3"_CS_"funding source for immunization"_CS_"LN"
Q
;-----
OBXFS4 ;osid
S INA("OBXFS4",INDA)="1"
Q
;-----
OBXFS5 ;ov
S INA("OBXFS5",INDA)=$$IVFS^BYIMIMM3(INDA)
Q
;-----
OBXFS11 ;abn
S INA("OBXFS11",INDA)="F"
Q
;-----
OBXFS14 ;edt
S INA("OBXFS14",INDA)=""
N X
S X=$P(X12,U)
S:'X X=$P(V0,U)
Q:'X
S INA("OBXFS14",INDA)=$E($$TIMEIO^INHUT10(X),1,8)
Q
;-----
OBXFSEND Q
;-----
;-----
RXR ;EP;
D RXR1
D RXR2
Q
;-----
RXR1 ;
S INA("RXR1",INDA)=""
N X,R
D VSET^BYIMSEGS(INDA)
S X=$P(X0,U,9)
Q:X=""
S R=$E(X,$L(X))
;PATCH 7 CORRECT IN TO NASAL
;S:X="O" R="O"
S:X="IN" R="N"
Q:"IDNOS"'[R
S:R="I" X="IM"_CS_"Intramuscular"
S:R="D" X="ID"_CS_"Intradermal"
S:R="N" X="NS"_CS_"Nasal"
S:R="O" X="PO"_CS_"Oral"
S:R="S" X="SC"_CS_"Subcutaneous"
S INA("RXR1",INDA)=X_CS_"HL70162"
Q
;-----
RXR2 ;
S INA("RXR2",INDA)=""
N X,R
D VSET^BYIMSEGS(INDA)
S X=$P(X0,U,9)
Q:X=""
S R=$E(X,1,2)
;PATCH 7 CORRECT SHIFT OF LI AND RI
;S:R="LI" R="LA"
;S:R="RI" R="RA"
Q:R="O"!(R="IN")
S:R="LT" X=R_CS_"Left Thigh"
S:R="LA" X=R_CS_"Left Arm"
S:R="LD" X=R_CS_"Left Deltoid"
S:R="LG" X=R_CS_"Left Gluteus Medius"
S:R="LL" X="LVL"_CS_"Left Vastus Lateralis"
S:R="LV" X="LVL"_CS_"Left Vastus Lateralis"
S:R="LI" X="LLFA"_CS_"Left Lower Forearm"
S:R="LL" X="LLFA"_CS_"Left Lower Forearm"
S:R="RA" X=R_CS_"Right Arm"
S:R="RT" X=R_CS_"Right Thigh"
S:R="RV" X="RVL"_CS_"Right Vastus Lateralis"
S:R="RG" X=R_CS_"Right Gluteous Medius"
S:R="RD" X=R_CS_"Right Deltoid"
S:R="RI" X="RLFA"_CS_"Right Lower Forearm"
S:R="RL" X="RLFA"_CS_"Right Lower Forearm"
S INA("RXR2",INDA)=X_CS_"HL70163"
RXREND Q
;-----
PD1 ;EP;
D PD13
D PD111
D PD112
D PD113
D PD116
D PD117
D PD118
Q
;-----
PD13 ;PD1-3 variable - location
S INA("PD13",1)=$G(BYIM("PD13.1"))_CS_$G(BYIM("PD13.2"))_CS_$G(BYIM("PD13.3"))
Q
;-----
PD111 ;PD1-11 PUBLICITY
S INA("PD111",1)=$$PUB^BYIMIMM3(INDA)
Q
;-----
PD112 ;PD1-12
S INA("PD112",1)=$$PROT^BYIMIMM3(INDA)
Q
;-----
PD113 ;PD1-13
S INA("PD113",1)=$$PROTDT^BYIMIMM3(INDA)
S:INA("PD112",1)="" INA("PD113",1)=""
I INA("PD112",1)]"",INA("PD113",1)="" S INA("PD113",1)=DT+17000000
Q
;-----
PD116 ;PD1-16
;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
S X=$P($G(^BIP(INDA,0)),U,8)
S INA("PD116",1)=$S('X:"A",1:"I")
;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
Q
;-----
PD117 ;PD1-17
;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
S INA("PD117",1)=$$ACTDT^BYIMIMM3(INDA)
;S:INA("PD117",1)="" INA("PD113",1)=DT+17000000
S:INA("PD117",1)="" INA("PD117",1)=DT+17000000
;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
Q
;-----
PD118 ;PD1-18
I INA("PD111",1)="" S INA("PD118",1)="" Q
S INA("PD118",1)=$$PUBDT^BYIMIMM3(INDA)
S:INA("PD118",1)="" INA("PD118",1)=DT+17000000
Q
;-----
PD1END Q
BYIMSEG1 ;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 ;this routine will contain code to supplement fields in the
+4 ;HL7 segments
+5 ;
IN1MCARE ;MEDICARE IN1 SEGMENTS
+1 ;PATCH 9 NMCI CHANGE MCR NUMBER
+2 SET INDA(1)=INDA
+3 DO IN1MCR17
+4 DO IN1MCR49
+5 ;PATCH 9 END
+6 QUIT
+7 ;-----
IN1MCR17 ;
+1 SET X="SEL^SELF^HL70063"
+2 SET INA("IN1MCR17")=X
+3 SET INA("IN1MCR17",1)=X
+4 SET INA("IN1MCR17",INDA)=X
+5 SET INA("IN1MCR17",INDA,1)=X
+6 SET INA("IN1MCR17",9000003,INDA)=X
+7 SET INA("IN1MCR17",9000003,INDA,1)=X
+8 QUIT
+9 ;-----
IN1MCR49 ;
+1 ;AUPN V99.1 PATCH 26 REQUIRED
+2 SET X=$$GETMCR^AGUTL(INDA,DT)
+3 SET INA("IN1MCR49")=X
+4 SET INA("IN1MCR49",1)=X
+5 SET INA("IN1MCR49",INDA)=X
+6 SET INA("IN1MCR49",INDA,1)=X
+7 SET INA("IN1MCR49",9000003,INDA)=X
+8 SET INA("IN1MCR49",9000003,INDA,1)=X
+9 QUIT
+10 ;-----
IN1RRE ;RAILROAD IN1 SEGMENTS
+1 ;PATCH 9 NMCI CHANGE MCR NUMBER
+2 ;AUPN V99.1 PATCH 26 REQUIRED
+3 SET INDA(1)=INDA
+4 DO IN1RRE49
+5 ;PATCH 9 END
+6 QUIT
+7 ;-----
IN1RRE49 ;
+1 ;AUPN V99.1 PATCH 26 REQUIRED
+2 SET X=$$GETRRE^AGUTL(INDA,DT)
+3 SET INA("IN1RRE49")=X
+4 SET INA("IN1RRE49",1)=X
+5 SET INA("IN1RRE49",INDA)=X
+6 SET INA("IN1RRE49",INDA,1)=X
+7 SET INA("IN1RRE49",9000003,INDA)=X
+8 SET INA("IN1RRE49",9000003,INDA,1)=X
+9 QUIT
+10 ;-----
OBXCE ;EP;
+1 DO VSET^BYIMSEGS(INDA)
+2 DO OBXCE1
+3 DO OBXCE2
+4 DO OBXCE3
+5 DO OBXCE4
+6 DO OBXCE5
+7 DO OBXCE11
+8 DO OBXCE14
+9 DO OBXCE17
+10 QUIT
+11 ;-----
OBXCE1 ;subid
+1 SET INA("OBXCE1",INDA)="1"
+2 QUIT
+3 ;-----
OBXCE2 ;vt
+1 SET INA("OBXCE2",INDA)="CE"
+2 QUIT
+3 ;-----
OBXCE3 ;od
+1 SET INA("OBXCE3",INDA)="64994-7"_CS_"funding eligibility for immunization"_CS_"LN"
+2 QUIT
+3 ;-----
OBXCE4 ;osid
+1 SET INA("OBXCE4",INDA)="1"
+2 QUIT
+3 ;-----
OBXCE5 ;ov
+1 SET INA("OBXCE5",INDA)=$$IVFC^BYIMIMM3(INDA)
+2 QUIT
+3 ;-----
OBXCE11 ;abn
+1 SET INA("OBXCE11",INDA)="F"
+2 QUIT
+3 ;-----
OBXCE14 ;edt
+1 SET INA("OBXCE14",INDA)=""
+2 NEW X
+3 SET X=$PIECE(X12,U)
+4 IF 'X
SET X=$PIECE(V0,U)
+5 IF 'X
QUIT
+6 SET INA("OBXCE14",INDA)=$EXTRACT($$TIMEIO^INHUT10(X),1,8)
+7 QUIT
+8 ;-----
OBXCE17 ;METHOD OF CAPTURE
+1 SET INA("OBXCE17",INDA)="VXC40"_CS_"per immunization"_CS_"CDCPHINVS"
OBXCEEND QUIT
+1 ;-----
+2 ;-----
OBXPR ;EP;VIS PRESENTED
+1 DO VSET^BYIMSEGS(INDA)
+2 DO OBXPR1
+3 DO OBXPR2
+4 DO OBXPR3
+5 DO OBXPR4
+6 DO OBXPR5
+7 QUIT
+8 ;-----
OBXPR1 ;subid
+1 SET INA("OBXPR1",INDA)="5"
+2 QUIT
+3 ;-----
OBXPR2 ;vt
+1 SET INA("OBXPR2",INDA)="TS"
+2 QUIT
+3 ;-----
OBXPR3 ;od
+1 SET INA("OBXPR3",INDA)="29769-7"_CS_"Date vaccine information statement presented"_CS_"LN"
+2 QUIT
+3 ;-----
OBXPR4 ;osid
+1 SET INA("OBXPR4",INDA)="2"
+2 QUIT
+3 ;-----
OBXPR5 ;ov
+1 NEW X
+2 SET X=""
+3 SET INA("OBXPR5",INDA)=""
+4 SET X=$PIECE(V0,".")
+5 IF X
SET X=X+17000000
+6 SET INA("OBXPR5",INDA)=X
OBXPREND QUIT
+1 ;-----
+2 ;-----
OBXPB ;EP;VIS PUBLISHED
+1 DO VSET^BYIMSEGS(INDA)
+2 DO OBXPB1
+3 DO OBXPB2
+4 DO OBXPB3
+5 DO OBXPB4
+6 DO OBXPB5
+7 QUIT
+8 ;-----
OBXPB1 ;subid
+1 SET INA("OBXPB1",INDA)="4"
+2 QUIT
+3 ;-----
OBXPB2 ;vt
+1 SET INA("OBXPB2",INDA)="TS"
+2 QUIT
+3 ;-----
OBXPB3 ;od
+1 SET INA("OBXPB3",INDA)="29768-9"_CS_"Date vaccine information statement published"_CS_"LN"
+2 QUIT
+3 ;-----
OBXPB4 ;osid
+1 SET INA("OBXPB4",INDA)="2"
+2 QUIT
+3 ;-----
OBXPB5 ;ov
+1 NEW X,Y,Z
+2 SET PUB=""
+3 SET INA("OBXPB5",INDA)=""
+4 DO PUB(X0)
+5 IF $LENGTH(PUB)=7
SET INA("OBXPB5",INDA)=PUB+17000000
OBXPBEND QUIT
+1 ;-----
+2 ;-----
REFUSAL(DFN,UIF) ;EP;TO CREATE REFUSAL RELATED SEGMENTS
+1 ;DFN = PATIENT DFN
+2 ;UIF = IEN FOR ^INTHU
+3 IF '$GET(UIF)
QUIT
+4 IF $GET(DFN)
DO R1(DFN,UIF)
+5 IF $GET(DFN)
DO V1(DFN,UIF)
+6 DO COMP(UIF)
+7 QUIT
+8 ;-----
R1(DFN,UIF) ;EP;FIND PATIENT RELATED REFUSALS
+1 ;DFN = PATIENT DFN
+2 ;UIF = IEN FOR ^INTHU
+3 ;N X,Y,Z
+4 ;PATCH 7 - CHANGE VARIABLE 'X' TO 'REFX'
+5 NEW REFX,Y,Z
+6 SET INDA=$ORDER(INA("ORC1",9999999999),-1)
+7 SET REFX=0
+8 FOR
SET REFX=$ORDER(^AUPNPREF("AC",DFN,REFX))
IF 'REFX
QUIT
SET X0=$GET(^AUPNPREF(REFX,0))
IF +X0=3
Begin DoDot:1
+9 ;PATCH 7 EXPAND QUIT LOGIC SO DOES NOT QUIT IF 'ALL' IMM'S
+10 ;Q:$D(^BYIMEXP("REF",REFX))
+11 IF $GET(^BYIMEXP("REF",REFX))
IF $GET(BYIMALL)'=2
QUIT
+12 IF '$PIECE(X0,U,6)
QUIT
+13 IF '$DATA(^AUTTIMM($PIECE(X0,U,6),0))
QUIT
+14 SET INDA=INDA+1
+15 SET Y="ORC|RE||9999^CDC|CR|"
+16 SET LCT=+$ORDER(^INTHU(UIF,3,9999999999),-1)+1
+17 SET ^INTHU(UIF,3,LCT,0)=Y
+18 SET V0=$PIECE(X0,U,3)
+19 NEW CS
+20 SET CS=U
+21 ;PATCH 7 GET PAT REFUSAL DATE DIRECTLY
+22 SET INA("RXA3",INDA)=$PIECE($GET(^AUPNPREF(REFX,0)),U,3)
+23 IF INA("RXA3",INDA)]""
SET INA("RXA3",INDA)=INA("RXA3",INDA)+17000000
+24 ;D RXA3^BYIMSEGS
+25 ;END CHANGE
+26 NEW IZDA
+27 SET IZDA=+$PIECE(X0,U,6)
+28 IF '$DATA(^AUTTIMM(IZDA,0))
SET IZDA=$PIECE(X0,U,4)
IF IZDA]""
SET IZDA=+$ORDER(^AUTTIMM("B",IZDA,0))
+29 SET Z0=$GET(^AUTTIMM(IZDA,0))
+30 DO RXA5^BYIMSEGS
+31 SET Z=$SELECT($PIECE($GET(^DPT(DFN,0)),U,3)<(DT-180000):"03^Patient decision",1:"00^Parental decision")_CS_"NIP002"
+32 SET LCT=+$ORDER(^INTHU(UIF,3,9999999999),-1)+1
+33 SET ^INTHU(UIF,3,LCT,0)="RXA|0|1|"_INA("RXA3",INDA)_"||"_INA("RXA5",INDA)_"|999|||01^HISTORICAL INFORMATION - SOURCE UNSPECIFIED^NIP001|||||||||"_Z_"||RE|CR|"
+34 ;PATCH 7 ADD IIS ID CODE FOR REFUSALS IF AVAILABLE
+35 SET X=$PIECE($GET(^BYIMPARA($$DUZ^BYIMIMM(),5,$$DUZ^BYIMIMM(),0)),U,2)
+36 IF X=""
SET X=$EXTRACT($PIECE($GET(^DIC(4,+$GET(^AUTTSITE(1,0)),0)),U),1,20)
+37 SET X="^^^"_X
+38 SET $PIECE(^INTHU(UIF,3,LCT,0),"|",12)=X
+39 IF '$GET(BYIMMU2)&'$GET(BYIMTEST)
SET ^BYIMEXP("REF",REFX)=DT
End DoDot:1
+40 QUIT
+41 ;-----
V1(DFN,UIF) ;EP;DETERMINE VARICELLA EXPOSURE
+1 ;DFN = PATIENT DFN
+2 ;UIF = IEN FOR ^INTHU
+3 IF '$DATA(^BIPC("B",+DFN))
QUIT
+4 NEW VDAT,BIX,LCT,ORC,RXA,OBX
+5 SET VDAT=""
+6 SET BIX=0
+7 FOR
SET BIX=$ORDER(^BIPC("B",DFN,BIX))
IF 'BIX
QUIT
IF $PIECE($GET(^BIPC(BIX,0)),U,2)
Begin DoDot:1
+8 IF $GET(^BYIMEXP("HXV",BIX))
IF $GET(BYIMALL)'=2
QUIT
+9 ;PATCH 7
+10 ;FILTER OUT NON-CONTRAINDICATION ENTRIES
+11 IF "^11^13^16^17^18^"[(U_$PIECE($GET(^BIPC(BIX,0)),U,3)_U)
QUIT
+12 SET IMM=$PIECE($GET(^BIPC(BIX,0)),U,2)
+13 SET VDAT=$PIECE(^BIPC(BIX,0),U,4)
+14 IF $LENGTH(VDAT)'=7
QUIT
+15 IF '$GET(BYIMMU2)
SET ^BYIMEXP("HXV",BIX)=VDAT
+16 SET LCT=+$ORDER(^INTHU(UIF,3,9999999999),-1)+1
+17 SET VDAT=VDAT+17000000
+18 SET ORC="ORC|RE||9999^CDC|CR|"
+19 SET RXA="RXA|0|1|"_VDAT_"|"_VDAT_"|998^No vaccine administered^CVX|999|"
+20 SET $PIECE(RXA,"|",21)="NA|CR|"
+21 NEW X
+22 SET X=$GET(^BYIMCON(IMM,0))
+23 IF X=""
SET OBX="OBX|1|CE|30945-0^Vaccination contraindication/precaution^LN|1|00000000^Reason not recorded^SCT||||||F|CR|"
+24 IF X]""
SET OBX="OBX|1|CE|30945-0^Vaccination contraindication/precaution^LN|1|"_$PIECE(X,U,2)_U_$PIECE(X,U,3)_"^SCT||||||F|CR|"
+25 SET ^INTHU(UIF,3,LCT,0)=ORC
+26 SET LCT=+$ORDER(^INTHU(UIF,3,9999999999),-1)+1
+27 SET ^INTHU(UIF,3,LCT,0)=RXA
+28 SET LCT=+$ORDER(^INTHU(UIF,3,9999999999),-1)+1
+29 SET ^INTHU(UIF,3,LCT,0)=OBX
End DoDot:1
+30 QUIT
+31 ;-----
COMP(UIF) ;EP;REFORMAT MESSAGE PRIOR TO TRANSMISSION
+1 ;UIF = IEN FOR ^INTHU
+2 NEW X,Y,Z,CNT
+3 KILL ^BYIMTMP("UIF",UIF)
+4 SET CNT=0
+5 SET XX=0
+6 FOR
SET XX=$ORDER(^INTHU(UIF,3,XX))
IF 'XX
QUIT
SET X=^(XX,0)
Begin DoDot:1
+7 SET CNT=$ORDER(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
+8 SET ^BYIMTMP("UIF",UIF,3,CNT,0)=X
+9 IF X'["ORC|"!($EXTRACT(X,1,4)'?3U1"|")
QUIT
+10 DO NORC(UIF)
+11 DO EVAL(UIF)
End DoDot:1
+12 KILL ^INTHU(UIF,3)
+13 SET X=0
+14 FOR
SET X=$ORDER(^BYIMTMP("UIF",UIF,3,X))
IF 'X
QUIT
SET Y=^(X,0)
IF Y]""
SET ^INTHU(UIF,3,X,0)=Y
+15 KILL ^BYIMTMP("UIF",UIF)
+16 QUIT
+17 ;-----
+18 ;-----
NORC(UIF) ;FIND NEXT ORC
+1 NEW X,Y,Z
+2 SET J=XX+1
+3 SET X=XX
+4 FOR
SET X=$ORDER(^INTHU(UIF,3,X))
IF 'X
QUIT
IF ^(X,0)["ORC|"
SET XX=X-1
QUIT
+5 IF J>XX
SET XX=$ORDER(^INTHU(UIF,3,9999999999),-1)
+6 QUIT
+7 ;-----
EVAL(UIF) ;EVAL FOR MULTIPLE VACCINE RXA'S
+1 NEW X,Y,Z,HIST,CNT,RXA,CVX,CVXDA,NAM,OBXPR,OBXPU
+2 SET RXA=""
+3 SET OBXPR=""
+4 SET OBXPU=""
+5 SET HIST=0
+6 FOR J=J:1:XX
Begin DoDot:1
+7 SET X2=""
SET X=$GET(^INTHU(UIF,3,J,0))
+8 IF X'["|CR|"
IF $GET(^INTHU(UIF,3,J+1,0))["|CR|"
SET X2=^(0)
SET J=J+1
+9 SET CNT=$ORDER(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
+10 IF $EXTRACT(X,1,4)="RXA|"
Begin DoDot:2
+11 SET RXA=X
+12 SET HIST=+$PIECE(RXA,"|",10)
End DoDot:2
+13 IF 'HIST
IF X'["vaccine info"
Begin DoDot:2
+14 SET ^BYIMTMP("UIF",UIF,3,CNT,0)=X
+15 IF X2]""
SET CNT=CNT+1
SET ^BYIMTMP("UIF",UIF,3,CNT,0)=X2
SET X2=""
End DoDot:2
+16 IF HIST
IF "|MSH|PID|ORC|RXA|"[("|"_$EXTRACT(X,1,3)_"|")
Begin DoDot:2
+17 SET ^BYIMTMP("UIF",UIF,3,CNT,0)=X
+18 IF X2]""
SET CNT=CNT+1
SET ^BYIMTMP("UIF",UIF,3,CNT,0)=X2
SET X2=""
End DoDot:2
+19 IF X["present"
SET OBXPR=$GET(^INTHU(UIF,3,J,0))
+20 IF X["publish"
SET OBXPU=$GET(^INTHU(UIF,3,J,0))
End DoDot:1
+21 IF RXA=""
QUIT
+22 IF HIST
QUIT
+23 IF $PIECE(RXA,"|",19)]""
QUIT
+24 SET CVX=+$PIECE(RXA,"|",6)
+25 SET CVXDA=+$ORDER(^AUTTIMM("C",CVX,0))
+26 SET X=$GET(^AUTTIMM(CVXDA,0))
+27 ;PATCH 7 GET DIRECT PUB DATE
+28 NEW ORPUB
+29 SET ORPUB=$PIECE(X,U,13)
+30 SET CMP=$PIECE($GET(^AUTTIMM(CVXDA,0)),U,21,26)
+31 IF $LENGTH(CMP)>5
DO E1(RXA,CMP)
QUIT
+32 IF $PIECE($GET(^BYIMNOS(CVXDA,0)),U,2)
SET X=$GET(^AUTTIMM(+$PIECE(^(0),U,2),0))
+33 SET NAM=$PIECE(X,U)
+34 SET CVX=+$PIECE(X,U,3)
+35 SET CVXDA=+$ORDER(^AUTTIMM("C",CVX,0))
+36 SET PUB=$PIECE(X,U,13)
+37 IF 'PUB
SET PUB=$PIECE($GET(^BYIMNOS(CVXDA,0)),U,3)
+38 ;PATCH 7 USE DIRECT PUB DATE IF NOT GENERIC DEFAULT
+39 IF 'PUB
SET PUB=ORPUB
+40 IF $GET(OBXPU)]""
Begin DoDot:1
+41 SET $PIECE(OBXPU,"|",6)=PUB+17000000
+42 IF OBXPU'["|CR|"
SET OBXPU=OBXPU_"|CR|"
+43 SET CNT=$ORDER(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
+44 SET ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPU
End DoDot:1
+45 IF $GET(OBXPR)]""
Begin DoDot:1
+46 IF OBXPR'["|CR|"
SET OBXPR=OBXPR_"|CR|"
+47 SET CNT=$ORDER(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
+48 SET ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPR
End DoDot:1
+49 QUIT
+50 ;-----
E1(RXA,CMP) ;
+1 NEW J,K,L,X,Y,Z,XX
+2 SET CNT=$ORDER(^BYIMTMP("UIF",UIF,3,9999999999),-1)
+3 SET X=$GET(^BYIMTMP("UIF",UIF,3,CNT,0))
+4 IF $EXTRACT(X,1,9)="OBX|3|CE|"
KILL ^BYIMTMP("UIF",UIF,3,CNT)
+5 SET K=2
+6 SET L=1
+7 FOR J=1:1:6
SET X=$PIECE(CMP,U,J)
IF X
Begin DoDot:1
+8 IF $PIECE($GET(^BYIMNOS(X,0)),U,2)
SET X=$PIECE(^(0),U,2)
SET NOSPUB=$PIECE(^(0),U,3)
+9 SET X=$GET(^AUTTIMM(X,0))
+10 SET NAM=$PIECE(X,U)
+11 SET CVX=$PIECE(X,U,3)
+12 SET PUB=$PIECE(X,U,13)
+13 IF 'PUB
IF NOSPUB
SET PUB=NOSPUB
+14 SET K=K+1
+15 SET L=L+1
+16 SET X="OBX|"_K_"|"
+17 SET $PIECE(X,"|",3)="CE"
+18 SET $PIECE(X,"|",4)="30956-7"_U_"vaccine type"_U_"LN"
+19 SET $PIECE(X,"|",5)=L
+20 SET $PIECE(X,"|",6)=(CVX_U_NAM_U_"CVX")
+21 SET $PIECE(X,"|",12)="F"
+22 SET CNT=$ORDER(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
+23 SET ^BYIMTMP("UIF",UIF,3,CNT,0)=X_"|CR|"
+24 SET K=K+1
+25 SET $PIECE(OBXPU,"|",2)=K
+26 SET $PIECE(OBXPU,"|",5)=L
+27 SET $PIECE(OBXPU,"|",6)=PUB+17000000
+28 SET $PIECE(OBXPU,"|",12)="F"
+29 SET CNT=$ORDER(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
+30 SET ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPU
+31 SET K=K+1
+32 SET $PIECE(OBXPR,"|",2)=K
+33 SET $PIECE(OBXPR,"|",5)=L
+34 SET $PIECE(OBXPR,"|",12)="F"
+35 SET CNT=$ORDER(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
+36 SET ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPR
End DoDot:1
+37 QUIT
+38 ;-----
+39 ;-----
OBXTY ;EP;
+1 DO VSET^BYIMSEGS(INDA)
+2 DO OBXTY1
+3 DO OBXTY2
+4 DO OBXTY3
+5 DO OBXTY4
+6 DO OBXTY5
+7 DO OBXTY11
+8 QUIT
+9 ;-----
OBXTY1 ;subid
+1 SET INA("OBXTY1",INDA)="3"
+2 QUIT
+3 ;-----
OBXTY2 ;vt
+1 SET INA("OBXTY2",INDA)="CE"
+2 QUIT
+3 ;-----
OBXTY3 ;od
+1 SET INA("OBXTY3",INDA)="30956-7"_CS_"vaccine type"_CS_"LN"
+2 QUIT
+3 ;-----
OBXTY4 ;osid
+1 SET INA("OBXTY4",INDA)="2"
+2 QUIT
+3 ;-----
OBXTY5 ;ov
+1 NEW X
+2 SET CVX=$PIECE(Z0,U,3)
+3 SET IDA=+$ORDER(^AUTTIMM("C",+CVX,0))
+4 IF $PIECE($GET(^BYIMNOS(IDA,0)),U,2)
SET IDA=$PIECE(^(0),U,2)
+5 SET X=$GET(^AUTTIMM(IDA,0))
+6 SET CVX=$PIECE(X,U,3)
+7 IF $LENGTH(CVX)=1
SET CVX="0"_CVX
+8 SET INA("OBXTY5",INDA)=CVX_CS_$PIECE(X,U)_CS_"CVX"
+9 QUIT
+10 ;-----
OBXTY11 ;abn
+1 SET INA("OBXTY11",INDA)="F"
+2 QUIT
+3 ;-----
OBXTYEND QUIT
+1 ;-----
+2 ;-----
QRF ;EP;main QRF routine driver
+1 SET INA("INQWHICH")="ANY"
+2 DO QRF1
+3 DO QRF2
+4 DO QRF3
+5 DO QRF5
+6 QUIT
+7 ;-----
QRF1 ;
+1 SET INA("QRF1")=$PIECE($GET(^DIC(4,$$DUZ^BYIMIMM(),0)),U)
+2 QUIT
QRF2 ;
+1 SET INA("QRF2")=""
+2 QUIT
+3 ;-----
QRF3 ;
+1 ;S INA("INQEDTM")=$G(INA("QEDT"))
+2 SET INA("QRF3")=""
+3 QUIT
+4 ;-----
QRF5 ;build the other query subject filter
+1 NEW BYIMDA,BYIMSSN,BYIMDOB,BYIMBST,BYIMBCN,BYIMMCN,BYIMMNM,BYIMMMN,BYIMMSSN,BYIMFNM
+2 SET BYIMDA=$ORDER(INA("QNM",0))
+3 IF 'BYIMDA
QUIT
+4 NEW X,Y,Z,X0,X24
+5 SET X0=$GET(^DPT(BYIMDA,0))
+6 IF X0=""
QUIT
+7 SET BYIMSSN=$TRANSLATE($PIECE(X0,U,9),"-")
+8 SET BYIMDOB=$PIECE(X0,U,3)+17000000
+9 SET BYIMBST=$PIECE($GET(^DIC(5,+$PIECE(X0,U,12),0)),U,2)
+10 SET BYIMBCN=$PIECE($GET(^AUPNPAT(BYIMDA,11)),U,5)
+11 SET BYIMMCN=""
+12 SET BYIMMNM=""
+13 SET BYIMMMN=""
+14 SET BYIMMSSN=""
+15 SET BYIMFNM=""
+16 SET X24=$GET(^DPT(BYIMDA,.24))
+17 SET X=$PIECE(X24,U,2)
+18 IF X]""
SET BYIMMNM=$$QRFNAME(X)
+19 SET X=$PIECE(X24,U,3)
+20 IF X]""
SET BYIMMMN=$$QRFNAME(X)
+21 SET X=$PIECE(X24,U)
+22 IF X]""
SET BYIMFNM=$$QRFNAME(X)
+23 SET BYIMFSSN=""
+24 SET INA("QRF5")=BYIMSSN_RS_BYIMDOB_RS_BYIMBST_RS_BYIMBCN_RS_BYIMMCN_RS_BYIMMNM_RS_BYIMMMN_RS_BYIMMSSN_RS_BYIMFNM_RS_BYIMFSSN
+25 QUIT
+26 ;-----
QRFNAME(NAME) ;FORMAT NAME
+1 IF NAME=""
QUIT ""
+2 SET X=$PIECE(NAME,",")_U_$PIECE($PIECE(NAME,",",2)," ")
+3 IF NAME[" "
SET X=X_U_$PIECE(NAME," ",2)
+4 QUIT X
QRFEND QUIT
+1 ;-----
+2 ;-----
FHS ;EP;
+1 QUIT
+2 ;-----
PUB(X0) ;FIND PUB DATE
+1 SET PUB=$PIECE(X0,U,12)
+2 IF $LENGTH(PUB)=7
QUIT
+3 SET IDA=+X0
+4 IF 'IDA
QUIT
+5 SET BYIMNOS=$GET(^BYIMNOS(IDA,0))
+6 ;PATCH 7 GET DIRECT PUB DATE IF NOS NOT DEFINED
+7 ;Q:'BYIMNOS
+8 IF 'BYIMNOS
SET PUB=$PIECE($GET(^AUTTIMM(IDA,0)),U,13)
QUIT
+9 SET NOSDA=+$PIECE(BYIMNOS,U,2)
+10 SET PUB=$PIECE(BYIMNOS,U,3)
+11 ;S:NOSDA=IDA PUB=$P(X0,U,12)
+12 IF 'PUB
IF NOSDA
SET PUB=$PIECE($GET(^AUTTIMM(NOSDA,0)),U,13)
+13 ;I 'PUB,NOSPUB S PUB=NOSPUB
+14 QUIT
OBXFS ;EP;
+1 ;PATCH 6 TO INCLUDE FUNDING SOURCE OBX SEGMENT
+2 DO VSET^BYIMSEGS(INDA)
+3 DO OBXFS1
+4 DO OBXFS2
+5 DO OBXFS3
+6 DO OBXFS4
+7 DO OBXFS5
+8 DO OBXFS11
+9 DO OBXFS14
+10 QUIT
+11 ;-----
OBXFS1 ;subid
+1 SET INA("OBXFS1",INDA)="2"
+2 QUIT
+3 ;-----
OBXFS2 ;vt
+1 SET INA("OBXFS2",INDA)="CE"
+2 QUIT
+3 ;-----
OBXFS3 ;od
+1 SET INA("OBXFS3",INDA)="30963-3"_CS_"funding source for immunization"_CS_"LN"
+2 QUIT
+3 ;-----
OBXFS4 ;osid
+1 SET INA("OBXFS4",INDA)="1"
+2 QUIT
+3 ;-----
OBXFS5 ;ov
+1 SET INA("OBXFS5",INDA)=$$IVFS^BYIMIMM3(INDA)
+2 QUIT
+3 ;-----
OBXFS11 ;abn
+1 SET INA("OBXFS11",INDA)="F"
+2 QUIT
+3 ;-----
OBXFS14 ;edt
+1 SET INA("OBXFS14",INDA)=""
+2 NEW X
+3 SET X=$PIECE(X12,U)
+4 IF 'X
SET X=$PIECE(V0,U)
+5 IF 'X
QUIT
+6 SET INA("OBXFS14",INDA)=$EXTRACT($$TIMEIO^INHUT10(X),1,8)
+7 QUIT
+8 ;-----
OBXFSEND QUIT
+1 ;-----
+2 ;-----
RXR ;EP;
+1 DO RXR1
+2 DO RXR2
+3 QUIT
+4 ;-----
RXR1 ;
+1 SET INA("RXR1",INDA)=""
+2 NEW X,R
+3 DO VSET^BYIMSEGS(INDA)
+4 SET X=$PIECE(X0,U,9)
+5 IF X=""
QUIT
+6 SET R=$EXTRACT(X,$LENGTH(X))
+7 ;PATCH 7 CORRECT IN TO NASAL
+8 ;S:X="O" R="O"
+9 IF X="IN"
SET R="N"
+10 IF "IDNOS"'[R
QUIT
+11 IF R="I"
SET X="IM"_CS_"Intramuscular"
+12 IF R="D"
SET X="ID"_CS_"Intradermal"
+13 IF R="N"
SET X="NS"_CS_"Nasal"
+14 IF R="O"
SET X="PO"_CS_"Oral"
+15 IF R="S"
SET X="SC"_CS_"Subcutaneous"
+16 SET INA("RXR1",INDA)=X_CS_"HL70162"
+17 QUIT
+18 ;-----
RXR2 ;
+1 SET INA("RXR2",INDA)=""
+2 NEW X,R
+3 DO VSET^BYIMSEGS(INDA)
+4 SET X=$PIECE(X0,U,9)
+5 IF X=""
QUIT
+6 SET R=$EXTRACT(X,1,2)
+7 ;PATCH 7 CORRECT SHIFT OF LI AND RI
+8 ;S:R="LI" R="LA"
+9 ;S:R="RI" R="RA"
+10 IF R="O"!(R="IN")
QUIT
+11 IF R="LT"
SET X=R_CS_"Left Thigh"
+12 IF R="LA"
SET X=R_CS_"Left Arm"
+13 IF R="LD"
SET X=R_CS_"Left Deltoid"
+14 IF R="LG"
SET X=R_CS_"Left Gluteus Medius"
+15 IF R="LL"
SET X="LVL"_CS_"Left Vastus Lateralis"
+16 IF R="LV"
SET X="LVL"_CS_"Left Vastus Lateralis"
+17 IF R="LI"
SET X="LLFA"_CS_"Left Lower Forearm"
+18 IF R="LL"
SET X="LLFA"_CS_"Left Lower Forearm"
+19 IF R="RA"
SET X=R_CS_"Right Arm"
+20 IF R="RT"
SET X=R_CS_"Right Thigh"
+21 IF R="RV"
SET X="RVL"_CS_"Right Vastus Lateralis"
+22 IF R="RG"
SET X=R_CS_"Right Gluteous Medius"
+23 IF R="RD"
SET X=R_CS_"Right Deltoid"
+24 IF R="RI"
SET X="RLFA"_CS_"Right Lower Forearm"
+25 IF R="RL"
SET X="RLFA"_CS_"Right Lower Forearm"
+26 SET INA("RXR2",INDA)=X_CS_"HL70163"
RXREND QUIT
+1 ;-----
PD1 ;EP;
+1 DO PD13
+2 DO PD111
+3 DO PD112
+4 DO PD113
+5 DO PD116
+6 DO PD117
+7 DO PD118
+8 QUIT
+9 ;-----
PD13 ;PD1-3 variable - location
+1 SET INA("PD13",1)=$GET(BYIM("PD13.1"))_CS_$GET(BYIM("PD13.2"))_CS_$GET(BYIM("PD13.3"))
+2 QUIT
+3 ;-----
PD111 ;PD1-11 PUBLICITY
+1 SET INA("PD111",1)=$$PUB^BYIMIMM3(INDA)
+2 QUIT
+3 ;-----
PD112 ;PD1-12
+1 SET INA("PD112",1)=$$PROT^BYIMIMM3(INDA)
+2 QUIT
+3 ;-----
PD113 ;PD1-13
+1 SET INA("PD113",1)=$$PROTDT^BYIMIMM3(INDA)
+2 IF INA("PD112",1)=""
SET INA("PD113",1)=""
+3 IF INA("PD112",1)]""
IF INA("PD113",1)=""
SET INA("PD113",1)=DT+17000000
+4 QUIT
+5 ;-----
PD116 ;PD1-16
+1 ;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
+2 SET X=$PIECE($GET(^BIP(INDA,0)),U,8)
+3 SET INA("PD116",1)=$SELECT('X:"A",1:"I")
+4 ;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
+5 QUIT
+6 ;-----
PD117 ;PD1-17
+1 ;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
+2 SET INA("PD117",1)=$$ACTDT^BYIMIMM3(INDA)
+3 ;S:INA("PD117",1)="" INA("PD113",1)=DT+17000000
+4 IF INA("PD117",1)=""
SET INA("PD117",1)=DT+17000000
+5 ;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
+6 QUIT
+7 ;-----
PD118 ;PD1-18
+1 IF INA("PD111",1)=""
SET INA("PD118",1)=""
QUIT
+2 SET INA("PD118",1)=$$PUBDT^BYIMIMM3(INDA)
+3 IF INA("PD118",1)=""
SET INA("PD118",1)=DT+17000000
+4 QUIT
+5 ;-----
PD1END QUIT
