BUDHRP6C ;IHS/CMI/LAB - UDS T6B PROCESS;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
;
GETIMMS(P,BDATE,EDATE,C,BUDX) ;EP
K BUDX
NEW X,Y,I,Z,V
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIMM(X,0)) ;happens
.S Y=$P(^AUPNVIMM(X,0),U)
.Q:'Y ;happens too
.S I=$P($G(^AUTTIMM(Y,0)),U,3) ;get HL7/CVX code
.F Z=1:1:$L(C,U) I I=$P(C,U,Z) S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".") I D]"",D'>EDATE,D'<BDATE S BUDX(D)="CVX: "_I_" on "_$$DATE^BUDHUTL1(D)
.Q
Q
;
IMM ;EP - IMM
;must have 2ND DOB between in the year - 2
S BUDX2YRB=($E(BUDBD,1,3)-2)_"0101"
S BUDX2YRE=($E(BUDED,1,3)-2)_"1231"
S BUDDOB=$P(^DPT(DFN,0),U,3)
Q:BUDDOB<BUDX2YRB
Q:BUDDOB>BUDX2YRE
S BUD2NDBD=$E(BUDDOB,1,3)+2_$E(BUDDOB,4,7)
S BUD1STBD=$E(BUDDOB,1,3)+1_$E(BUDDOB,4,7)
;
Q:BUDMEDV<1 ;didn't have at least 1 medical visit
;V18 hospice
Q:$$HOSPIND(DFN,BUDBD,BUDED) ;new v18, hospice during report period
;
S BUDSECTC("PTS")=$G(BUDSECTC("PTS"))+1
S BUDX42D=$$FMADD^XLFDT(BUDDOB,42)
S BUDX180D=$$FMADD^XLFDT(BUDDOB,180)
S (BUDNDTP,BUDNIPV,BUDNMMR,BUDNHEP,BUDNHIB,BUDNVAR,BUDNPNEU,BUDNHEPA,BUDNROTA,BUDNFLU)=""
S BUDNDTP=$$DTAP^BUDHRP6X(DFN,BUDX42D,BUD2NDBD)
S BUDNIPV=$$IPV(DFN,BUDX42D,BUD2NDBD)
S BUDNMMR=$$MMR^BUDHRP6D(DFN,BUDDOB,BUD2NDBD)
S BUDNHIB=$$HIB^BUDHRP6Y(DFN,BUDX42D,BUD2NDBD)
S BUDNHEP=$$HEPB^BUDHRP6Y(DFN,BUDDOB,BUD2NDBD)
S BUDNVAR=$$VAR^BUDHRP6Y(DFN,BUD1STBD,BUD2NDBD)
S BUDNPNEU=$$PNEU^BUDHRP6Y(DFN,BUDDOB,BUD2NDBD)
S BUDNHEPA=$$HEPA^BUDHRP6H(DFN,BUDDOB,BUD2NDBD)
S BUDNROTA=$$ROTA^BUDHRP6H(DFN,BUDX42D,BUD2NDBD)
S BUDNFLU=$$FLU^BUDHRP6H(DFN,BUDX180D,BUD2NDBD)
I $P(BUDNDTP,U,1)=1,$P(BUDNIPV,U,1)=1,$P(BUDNMMR,U,1)=1,$P(BUDNHEP,U,1)=1,$P(BUDNHIB,U,1)=1,$P(BUDNVAR,U,1)=1,$P(BUDNPNEU,U,1)=1,$P(BUDNHEPA,U,1)=1,$P(BUDNROTA,U,1)=1,$P(BUDNFLU,U,1)=1 S BUDSECTC("IMM")=$G(BUDSECTC("IMM"))+1 D Q
.I $G(BUDIMM1L) D
..S X=$P(BUDNDTP,U,2)_U_$P(BUDNIPV,U,2)_U_$P(BUDNMMR,U,2)_U_$P(BUDNHEP,U,2)_U_$P(BUDNHIB,U,2)_U_$P(BUDNVAR,U,2)_U_$P(BUDNPNEU,U,2)_U_$P(BUDNHEPA,U,2)_U_$P(BUDNROTA,U,2)_U_$P(BUDNFLU,U,2)_"|||"_U_BUDMEDVI
..S ^XTMP("BUDHRP6B",BUDJ,BUDH,"IMM1",$P(^DPT(DFN,0),U),BUDCCOM,DFN)=X
..Q
I $G(BUDIMM2L) D
.S V=""
.S V=$S($P(BUDNDTP,U,1)=1:"",1:$P(BUDNDTP,U,2))
.I $P(BUDNIPV,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNIPV,U,2)
.I $P(BUDNMMR,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNMMR,U,2)
.I $P(BUDNHEP,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNHEP,U,2)
.I $P(BUDNHIB,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNHIB,U,2)
.I $P(BUDNVAR,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNVAR,U,2)
.I $P(BUDNPNEU,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNPNEU,U,2)
.I $P(BUDNHEPA,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNHEPA,U,2)
.I $P(BUDNROTA,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNROTA,U,2)
.I $P(BUDNFLU,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNFLU,U,2)
.S ^XTMP("BUDHRP6B",BUDJ,BUDH,"IMM2",$P(^DPT(DFN,0),U),BUDCCOM,DFN)=V
Q
;
HOSPIND(P,BDATE,EDATE) ;EP - Hospice indicator IPC
;GET ALL VISITS IN TIME PERIOD
;CHECK SNOMED FOR INPATIENT AND DSCH
;CHECK OUTPATIENT SNOMED IN V POV
;CHECK PROBLEM LIST ENTRIES FOR NOT INACTIVE AND NOT DELETED
;
;1. CHECK V POV FOR SNOMED CODES
NEW S,Y,T,G,D,M,O,A,B,V,T1
S T=$O(^BUDHTSSC("B","PXRM BGP IPC HOSPICE",0))
S G=""
S S=0 F S S=$O(^BUDHTSSC(T,13,"B",S)) Q:S=""!(G) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y<BDATE
..Q:Y>EDATE
..S G=1
I G Q G
I $$IPLSNOND^BUDHDU(P,"PXRM BGP IPC HOSPICE",EDATE,1) Q 1
I G Q G
;check all discharges V Hospitalization discharges during the report period
S X=0,G=""
F S X=$O(^AUPNVINP("AC",P,X)) Q:X'=+X!(G) D
.Q:'$D(^AUPNVINP(X,0))
.S D=$P($P(^AUPNVINP(X,0),U),".")
.I D<BDATE Q
.I D>EDATE Q
.;is where seen correct?
.S V=$P(^AUPNVINP(X,0),U,3)
.Q:'V
.S Z=0
.S T=$O(^BUDHTSSC("B","PXRM BGP IPC INPT ENC",0))
.S T1=$O(^BUDHTSSC("B","PXRM BGP IPC DISCHG HOSPICE",0))
.S A=0 F S A=$O(^AUPNVSIT(V,26,"B",A)) Q:A="" I $D(^BUDHTSSC(T,13,"B",A)) S Z=1
.S Y=$$VAL^XBDIQ1(9000010.02,X,6107)
.I Z,Y]"",$D(^BUDHTSSC(T1,13,"B",Y)) S G=1
.I G Q
.S A=0 F S A=$O(^AUPNVSIT(V,28,"B",A)) Q:A="" I $D(^BUDHTSSC(T,13,"B",A)) S Z=1
.S Y=$$VAL^XBDIQ1(9000010.02,X,6107)
.I Z,Y]"",$D(^BUDHTSSC(T1,13,"B",Y)) S G=1
Q G
CONTRA(P,BD,ED,T1,LABEL) ;EP - CONTRA TO ALL VACCINES T CODES
NEW D,BUDG,E,%
K BUDG S %=P_"^ALL DX;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(")
NEW X,Y,G,T,V,Z,A
S T=$O(^BUDHTSSC("B","T6B IMM CONTRA ALL VACCINES",0))
S G=""
S X=0 F S X=$O(BUDG(X)) Q:X'=+X!(G]"") D
.S Y=+$P(BUDG(X),U,4)
.S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
.Q:'$D(^BUDHTSSC("AD",Y,T))
.S V=$P(BUDG(X),U,5)
.S Z=0 F S Z=$O(^AUPNVIMM("AD",V,Z)) Q:Z'=+Z!(G) D
..S A=$P(^AUPNVIMM(Z,0),U,1)
..S A=+$P($G(^AUTTIMM(A,0)),U,3)
..I A="" Q
..Q:'$D(^BUDHTSSC(T1,15,"B",A))
..S G=1_U_LABEL_": CONTRA "_$P(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U,1))
.;CPT
.S Z=0 F S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(G) D
..S A=$$VAL^XBDIQ1(9000010.18,Z,.01)
..I A="" Q
..Q:'$D(^BUDHTSSC("AC",A,T1))
..S G=1_U_LABEL_": CONTRA "_$P(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U,1))
.;POV
.S Z=0 F S Z=$O(^AUPNVPOV("AD",V,Z)) Q:Z'=+Z!(G) D
..S A=$$VALI^XBDIQ1(9000010.07,Z,.01)
..I A="" Q
..I $D(^BUDHTSSC("AD",A,T1)) S G=1_U_LABEL_": CONTRA "_$P(BUDG(X),U,2)_"/"_$$VAL^XBDIQ1(9000010.07,Z,.01)_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U,1))
..S A=$$VAL^XBDIQ1(9000010.07,Z,1101)
..Q:A=""
..I $D(^BUDHTSSC("AS",A,T1)) S G=1_U_LABEL_": CONTRA "_$P(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U,1))
Q G
ANAREACT(I) ;EP
NEW X,Y,R
S X=0,Y=0 F S X=$O(^GMR(120.8,I,10,X)) Q:X'=+X D
.S R=$P($G(^GMR(120.8,I,10,X,0)),U)
.Q:R=""
.S R=$P($G(^GMRD(120.83,R,0)),U)
.I R'="ANAPHYLAXIS" Q
.S Y=1
.Q
Q Y
;
ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRA
NEW X,G,D,R,Y
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.;Q:$P(^BIPC(X,0),U,4)<BD
.;Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
.I $P(^BICONT(R,0),U,1)="Baker's Yeast Allergy" S G=D_U_"Baker's Yeast Allergy"
.I $P(^BICONT(R,0),U,1)="Yeast Allergy" S G=D_U_"Yeast Allergy"
Q G
;
EGGCONT(P,C,ED) ;EP - EGG CONTRA
NEW X,G,Y,R,D
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.;Q:$P(^BIPC(X,0),U,4)<BD
.;Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Egg Allergy" S G=D_U_"Egg Allergy"
Q G
ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRA
NEW X,G,Y,R,D
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
.I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Neomycin Allergy"
.I $P(^BICONT(R,0),U,1)="Streptomycin Allergy" S G=D_U_"Streptomycin Allergy"
.I $P(^BICONT(R,0),U,1)="Polymyxin B Allergy" S G=D_U_"Polymyxin B Allergy"
Q G
;
MMRCONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN/IMMUNE CONTRA
NEW X,R,Y,D
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.;Q:$P(^BIPC(X,0),U,4)<BD
.;Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
.I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Neomycin Allergy"
.I $P(^BICONT(R,0),U,1)="Immune Deficiency" S G=D_U_"Immune Deficiency"
.I $P(^BICONT(R,0),U,1)["Immune Deficient" S G=D_U_"Immune Deficient"
.I $P(^BICONT(R,0),U,1)="Immune" S G=D_U_"Immune"
Q G
;
;
IPV(P,BDATE,EDATE) ;EP
;check for a contraindication from DOB to 2nd birthday
NEW G,X,N,T,BUDZ,BUDG,%,E,Y,BUDD,BUDX,BUDOPV,BUDVS,TIEN,CTR,VIEN,VDATE,C
IPVCONT ;check allergy tracking
S G=""
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(G) D
.;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["STREPTOMYCIN"!(N["POLYMYXIN B")!(N["NEOMYCIN") S G="1^IPV: CONTRA "_$$DATE^BUDHUTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
.Q:'$$ANAREACT(X) ;quit if anaphylactic is not a reaction/sign/symptom
I G]"" Q G
;now check immunization package
S T=$O(^BUDHTSSC("B","T6B IMM IPV CODES",0))
S X=""
S BUDZ=0 F S BUDZ=$O(^BUDHTSSC(T,15,"B",BUDZ)) Q:BUDZ'=+BUDZ!(X]"") D
.S X=$$ANNECONT(P,BUDZ,EDATE)
I X]"" Q "1^IPV: CONTRA IMM package: "_$$DATE^BUDHUTL1($P(X,U))_" "_$P(X,U,2)
S T=$O(^BUDHTSSC("B","T6B IMM IPV CODES",0))
S BUDZ=0 F S BUDZ=$O(^BUDHTSSC(T,15,"B",BUDZ)) Q:BUDZ'=+BUDZ!(X]"") D
.S X=$$MMRCONT(P,BUDZ,EDATE)
I X]"" Q "1^IPV: CONTRA IMM package: "_$$DATE^BUDHUTL1($P(X,U))_" "_$P(X,U,2)
;ALL VACCINE CONTRA
S X=$$CONTRA(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDHTSSC("B","T6B IMM IPV CODES",0)),"IPV")
I X]"" Q X
;now check snomed contra codes
;SNOMED ANALPHALACTIC V POV OR PROBLEM LIST?
S T=$O(^BUDHTSSC("B","T6B IMM CONTRA IPV",0))
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q ;entered after report period, skip
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S]"",$D(^BUDHTSSC("AS",S,T)) S I="1^IPV: CONTRA PL "_S Q
.Q
I I Q I
;NOW V POV SNOMED
S G="",I=""
S S="" F S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G) D
.S I=0
.I $D(^BUDHTSSC("AS",S,T)) S I="1^IPV: CONTRA POV "_S
.Q:'I
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=I_"^"_$$DATE^BUDHUTL1(Y)
I G Q G
IPVEVID ;
;NOW EVIDENCE OF DISEASE
S G=$$PLTAXND^BUDHDU(P,"BUD 18 IPV EVIDENCE",EDATE,0) I G Q "1^IPV: EVID PL "_$P(G,U,2)_" on "_$$DATE^BUDHUTL1($P(G,U,3))
S G=$$LASTDX^BUDHUTL1(P,"BUD 18 IPV EVIDENCE",$$DOB^AUPNPAT(P),EDATE) I G Q "1^IPV: EVID DX "_$P(G,U,2)_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U,3))
K BUDD,BUDG,BUDX
K BUDOPV,BUDAPOV
IPVIMM ;get all immunizations
S BUDOPV=0
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS") ;all visits in 42 days to end
S TIEN=$O(^BUDHTSSC("B","T6B IMM IPV CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.S X=0 F S X=$O(^AUPNVIMM("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVIMM(X,0))
..S Y=$$VALI^XBDIQ1(9000010.11,X,.01)
..S Y=+$P($G(^AUTTIMM(Y,0)),U,3)
..Q:'Y
..I $D(^BUDHTSSC(TIEN,15,"B",Y)) S BUDOPV(VDATE)="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDOPV(VDATE)="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDOPV(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
.;V PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDHTSSC("AP",Y,TIEN)) S BUDOPV(VDATE)="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDHTSSC("AS",Y,TIEN)) S BUDOPV(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BUDOPV(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDOPV(X) Q
.S Y=X
;now count them and see if there are 3 of them
S BUDOPV=0,X=0 F S X=$O(BUDOPV(X)) Q:X'=+X S BUDOPV=BUDOPV+1
I BUDOPV>2 S Y="1^IPV: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>2 Q Y
Q "0^"_(3-BUDOPV)_" IPV"
;
ANALCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRA
NEW X,G,D,R,Y
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.;Q:$P(^BIPC(X,0),U,4)<BD
.;Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
Q G
;
BUDHRP6C ;IHS/CMI/LAB - UDS T6B PROCESS;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;
+3 ;
GETIMMS(P,BDATE,EDATE,C,BUDX) ;EP
+1 KILL BUDX
+2 NEW X,Y,I,Z,V
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;happens
IF '$DATA(^AUPNVIMM(X,0))
QUIT
+5 SET Y=$PIECE(^AUPNVIMM(X,0),U)
+6 ;happens too
IF 'Y
QUIT
+7 ;get HL7/CVX code
SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+8 FOR Z=1:1:$LENGTH(C,U)
IF I=$PIECE(C,U,Z)
SET V=$PIECE(^AUPNVIMM(X,0),U,3)
IF V
SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
IF D]""
IF D'>EDATE
IF D'<BDATE
SET BUDX(D)="CVX: "_I_" on "_$$DATE^BUDHUTL1(D)
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
IMM ;EP - IMM
+1 ;must have 2ND DOB between in the year - 2
+2 SET BUDX2YRB=($EXTRACT(BUDBD,1,3)-2)_"0101"
+3 SET BUDX2YRE=($EXTRACT(BUDED,1,3)-2)_"1231"
+4 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+5 IF BUDDOB<BUDX2YRB
QUIT
+6 IF BUDDOB>BUDX2YRE
QUIT
+7 SET BUD2NDBD=$EXTRACT(BUDDOB,1,3)+2_$EXTRACT(BUDDOB,4,7)
+8 SET BUD1STBD=$EXTRACT(BUDDOB,1,3)+1_$EXTRACT(BUDDOB,4,7)
+9 ;
+10 ;didn't have at least 1 medical visit
IF BUDMEDV<1
QUIT
+11 ;V18 hospice
+12 ;new v18, hospice during report period
IF $$HOSPIND(DFN,BUDBD,BUDED)
QUIT
+13 ;
+14 SET BUDSECTC("PTS")=$GET(BUDSECTC("PTS"))+1
+15 SET BUDX42D=$$FMADD^XLFDT(BUDDOB,42)
+16 SET BUDX180D=$$FMADD^XLFDT(BUDDOB,180)
+17 SET (BUDNDTP,BUDNIPV,BUDNMMR,BUDNHEP,BUDNHIB,BUDNVAR,BUDNPNEU,BUDNHEPA,BUDNROTA,BUDNFLU)=""
+18 SET BUDNDTP=$$DTAP^BUDHRP6X(DFN,BUDX42D,BUD2NDBD)
+19 SET BUDNIPV=$$IPV(DFN,BUDX42D,BUD2NDBD)
+20 SET BUDNMMR=$$MMR^BUDHRP6D(DFN,BUDDOB,BUD2NDBD)
+21 SET BUDNHIB=$$HIB^BUDHRP6Y(DFN,BUDX42D,BUD2NDBD)
+22 SET BUDNHEP=$$HEPB^BUDHRP6Y(DFN,BUDDOB,BUD2NDBD)
+23 SET BUDNVAR=$$VAR^BUDHRP6Y(DFN,BUD1STBD,BUD2NDBD)
+24 SET BUDNPNEU=$$PNEU^BUDHRP6Y(DFN,BUDDOB,BUD2NDBD)
+25 SET BUDNHEPA=$$HEPA^BUDHRP6H(DFN,BUDDOB,BUD2NDBD)
+26 SET BUDNROTA=$$ROTA^BUDHRP6H(DFN,BUDX42D,BUD2NDBD)
+27 SET BUDNFLU=$$FLU^BUDHRP6H(DFN,BUDX180D,BUD2NDBD)
+28 IF $PIECE(BUDNDTP,U,1)=1
IF $PIECE(BUDNIPV,U,1)=1
IF $PIECE(BUDNMMR,U,1)=1
IF $PIECE(BUDNHEP,U,1)=1
IF $PIECE(BUDNHIB,U,1)=1
IF $PIECE(BUDNVAR,U,1)=1
IF $PIECE(BUDNPNEU,U,1)=1
IF $PIECE(BUDNHEPA,U,1)=1
IF $PIECE(BUDNROTA,U,1)=1
IF $PIECE(BUDNFLU,U,1)=1
SET BUDSECTC("IMM")=$GET(BUDSECTC("IMM"))+1
Begin DoDot:1
+29 IF $GET(BUDIMM1L)
Begin DoDot:2
+30 SET X=$PIECE(BUDNDTP,U,2)_U_$PIECE(BUDNIPV,U,2)_U_$PIECE(BUDNMMR,U,2)_U_$PIECE(BUDNHEP,U,2)_U_$PIECE(BUDNHIB,U,2)_U_$PIECE(BUDNVAR,U,2)_U_$PIECE(BUDNPNEU,U,2)_U_$PIECE(BUDNHEPA,U,2)_U_$PIECE(B
UDNROTA,U,2)_U_$PIECE(BUDNFLU,U,2)_"|||"_U_BUDMEDVI
+31 SET ^XTMP("BUDHRP6B",BUDJ,BUDH,"IMM1",$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=X
+32 QUIT
End DoDot:2
End DoDot:1
QUIT
+33 IF $GET(BUDIMM2L)
Begin DoDot:1
+34 SET V=""
+35 SET V=$SELECT($PIECE(BUDNDTP,U,1)=1:"",1:$PIECE(BUDNDTP,U,2))
+36 IF $PIECE(BUDNIPV,U,1)'=1
IF V]""
SET V=V_"; "
SET V=V_$PIECE(BUDNIPV,U,2)
+37 IF $PIECE(BUDNMMR,U,1)'=1
IF V]""
SET V=V_"; "
SET V=V_$PIECE(BUDNMMR,U,2)
+38 IF $PIECE(BUDNHEP,U,1)'=1
IF V]""
SET V=V_"; "
SET V=V_$PIECE(BUDNHEP,U,2)
+39 IF $PIECE(BUDNHIB,U,1)'=1
IF V]""
SET V=V_"; "
SET V=V_$PIECE(BUDNHIB,U,2)
+40 IF $PIECE(BUDNVAR,U,1)'=1
IF V]""
SET V=V_"; "
SET V=V_$PIECE(BUDNVAR,U,2)
+41 IF $PIECE(BUDNPNEU,U,1)'=1
IF V]""
SET V=V_"; "
SET V=V_$PIECE(BUDNPNEU,U,2)
+42 IF $PIECE(BUDNHEPA,U,1)'=1
IF V]""
SET V=V_"; "
SET V=V_$PIECE(BUDNHEPA,U,2)
+43 IF $PIECE(BUDNROTA,U,1)'=1
IF V]""
SET V=V_"; "
SET V=V_$PIECE(BUDNROTA,U,2)
+44 IF $PIECE(BUDNFLU,U,1)'=1
IF V]""
SET V=V_"; "
SET V=V_$PIECE(BUDNFLU,U,2)
+45 SET ^XTMP("BUDHRP6B",BUDJ,BUDH,"IMM2",$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=V
End DoDot:1
+46 QUIT
+47 ;
HOSPIND(P,BDATE,EDATE) ;EP - Hospice indicator IPC
+1 ;GET ALL VISITS IN TIME PERIOD
+2 ;CHECK SNOMED FOR INPATIENT AND DSCH
+3 ;CHECK OUTPATIENT SNOMED IN V POV
+4 ;CHECK PROBLEM LIST ENTRIES FOR NOT INACTIVE AND NOT DELETED
+5 ;
+6 ;1. CHECK V POV FOR SNOMED CODES
+7 NEW S,Y,T,G,D,M,O,A,B,V,T1
+8 SET T=$ORDER(^BUDHTSSC("B","PXRM BGP IPC HOSPICE",0))
+9 SET G=""
+10 SET S=0
FOR
SET S=$ORDER(^BUDHTSSC(T,13,"B",S))
IF S=""!(G)
QUIT
Begin DoDot:1
+11 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+12 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+13 SET Y=9999999-D
+14 IF Y<BDATE
QUIT
+15 IF Y>EDATE
QUIT
+16 SET G=1
End DoDot:2
End DoDot:1
+17 IF G
QUIT G
+18 IF $$IPLSNOND^BUDHDU(P,"PXRM BGP IPC HOSPICE",EDATE,1)
QUIT 1
+19 IF G
QUIT G
+20 ;check all discharges V Hospitalization discharges during the report period
+21 SET X=0
SET G=""
+22 FOR
SET X=$ORDER(^AUPNVINP("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+23 IF '$DATA(^AUPNVINP(X,0))
QUIT
+24 SET D=$PIECE($PIECE(^AUPNVINP(X,0),U),".")
+25 IF D<BDATE
QUIT
+26 IF D>EDATE
QUIT
+27 ;is where seen correct?
+28 SET V=$PIECE(^AUPNVINP(X,0),U,3)
+29 IF 'V
QUIT
+30 SET Z=0
+31 SET T=$ORDER(^BUDHTSSC("B","PXRM BGP IPC INPT ENC",0))
+32 SET T1=$ORDER(^BUDHTSSC("B","PXRM BGP IPC DISCHG HOSPICE",0))
+33 SET A=0
FOR
SET A=$ORDER(^AUPNVSIT(V,26,"B",A))
IF A=""
QUIT
IF $DATA(^BUDHTSSC(T,13,"B",A))
SET Z=1
+34 SET Y=$$VAL^XBDIQ1(9000010.02,X,6107)
+35 IF Z
IF Y]""
IF $DATA(^BUDHTSSC(T1,13,"B",Y))
SET G=1
+36 IF G
QUIT
+37 SET A=0
FOR
SET A=$ORDER(^AUPNVSIT(V,28,"B",A))
IF A=""
QUIT
IF $DATA(^BUDHTSSC(T,13,"B",A))
SET Z=1
+38 SET Y=$$VAL^XBDIQ1(9000010.02,X,6107)
+39 IF Z
IF Y]""
IF $DATA(^BUDHTSSC(T1,13,"B",Y))
SET G=1
End DoDot:1
+40 QUIT G
CONTRA(P,BD,ED,T1,LABEL) ;EP - CONTRA TO ALL VACCINES T CODES
+1 NEW D,BUDG,E,%
+2 KILL BUDG
SET %=P_"^ALL DX;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+3 NEW X,Y,G,T,V,Z,A
+4 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA ALL VACCINES",0))
+5 SET G=""
+6 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+7 SET Y=+$PIECE(BUDG(X),U,4)
+8 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+9 IF '$DATA(^BUDHTSSC("AD",Y,T))
QUIT
+10 SET V=$PIECE(BUDG(X),U,5)
+11 SET Z=0
FOR
SET Z=$ORDER(^AUPNVIMM("AD",V,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+12 SET A=$PIECE(^AUPNVIMM(Z,0),U,1)
+13 SET A=+$PIECE($GET(^AUTTIMM(A,0)),U,3)
+14 IF A=""
QUIT
+15 IF '$DATA(^BUDHTSSC(T1,15,"B",A))
QUIT
+16 SET G=1_U_LABEL_": CONTRA "_$PIECE(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U,1))
End DoDot:2
+17 ;CPT
+18 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+19 SET A=$$VAL^XBDIQ1(9000010.18,Z,.01)
+20 IF A=""
QUIT
+21 IF '$DATA(^BUDHTSSC("AC",A,T1))
QUIT
+22 SET G=1_U_LABEL_": CONTRA "_$PIECE(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U,1))
End DoDot:2
+23 ;POV
+24 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPOV("AD",V,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+25 SET A=$$VALI^XBDIQ1(9000010.07,Z,.01)
+26 IF A=""
QUIT
+27 IF $DATA(^BUDHTSSC("AD",A,T1))
SET G=1_U_LABEL_": CONTRA "_$PIECE(BUDG(X),U,2)_"/"_$$VAL^XBDIQ1(9000010.07,Z,.01)_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U,1))
+28 SET A=$$VAL^XBDIQ1(9000010.07,Z,1101)
+29 IF A=""
QUIT
+30 IF $DATA(^BUDHTSSC("AS",A,T1))
SET G=1_U_LABEL_": CONTRA "_$PIECE(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U,1))
End DoDot:2
End DoDot:1
+31 QUIT G
ANAREACT(I) ;EP
+1 NEW X,Y,R
+2 SET X=0
SET Y=0
FOR
SET X=$ORDER(^GMR(120.8,I,10,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET R=$PIECE($GET(^GMR(120.8,I,10,X,0)),U)
+4 IF R=""
QUIT
+5 SET R=$PIECE($GET(^GMRD(120.83,R,0)),U)
+6 IF R'="ANAPHYLAXIS"
QUIT
+7 SET Y=1
+8 QUIT
End DoDot:1
+9 QUIT Y
+10 ;
ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRA
+1 NEW X,G,D,R,Y
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 ;Q:$P(^BIPC(X,0),U,4)>ED
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Anaphylaxis"
+11 IF $PIECE(^BICONT(R,0),U,1)="Baker's Yeast Allergy"
SET G=D_U_"Baker's Yeast Allergy"
+12 IF $PIECE(^BICONT(R,0),U,1)="Yeast Allergy"
SET G=D_U_"Yeast Allergy"
End DoDot:1
+13 QUIT G
+14 ;
EGGCONT(P,C,ED) ;EP - EGG CONTRA
+1 NEW X,G,Y,R,D
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 ;Q:$P(^BIPC(X,0),U,4)>ED
+10 IF $PIECE(^BICONT(R,0),U,1)="Egg Allergy"
SET G=D_U_"Egg Allergy"
End DoDot:1
+11 QUIT G
ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRA
+1 NEW X,G,Y,R,D
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Anaphylaxis"
+9 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Neomycin Allergy"
+10 IF $PIECE(^BICONT(R,0),U,1)="Streptomycin Allergy"
SET G=D_U_"Streptomycin Allergy"
+11 IF $PIECE(^BICONT(R,0),U,1)="Polymyxin B Allergy"
SET G=D_U_"Polymyxin B Allergy"
End DoDot:1
+12 QUIT G
+13 ;
MMRCONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN/IMMUNE CONTRA
+1 NEW X,R,Y,D
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 ;Q:$P(^BIPC(X,0),U,4)>ED
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Anaphylaxis"
+11 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Neomycin Allergy"
+12 IF $PIECE(^BICONT(R,0),U,1)="Immune Deficiency"
SET G=D_U_"Immune Deficiency"
+13 IF $PIECE(^BICONT(R,0),U,1)["Immune Deficient"
SET G=D_U_"Immune Deficient"
+14 IF $PIECE(^BICONT(R,0),U,1)="Immune"
SET G=D_U_"Immune"
End DoDot:1
+15 QUIT G
+16 ;
+17 ;
IPV(P,BDATE,EDATE) ;EP
+1 ;check for a contraindication from DOB to 2nd birthday
+2 NEW G,X,N,T,BUDZ,BUDG,%,E,Y,BUDD,BUDX,BUDOPV,BUDVS,TIEN,CTR,VIEN,VDATE,C
IPVCONT ;check allergy tracking
+1 SET G=""
+2 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 ;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
+4 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+5 IF N["STREPTOMYCIN"!(N["POLYMYXIN B")!(N["NEOMYCIN")
SET G="1^IPV: CONTRA "_$$DATE^BUDHUTL1($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
+6 ;quit if anaphylactic is not a reaction/sign/symptom
IF '$$ANAREACT(X)
QUIT
End DoDot:1
+7 IF G]""
QUIT G
+8 ;now check immunization package
+9 SET T=$ORDER(^BUDHTSSC("B","T6B IMM IPV CODES",0))
+10 SET X=""
+11 SET BUDZ=0
FOR
SET BUDZ=$ORDER(^BUDHTSSC(T,15,"B",BUDZ))
IF BUDZ'=+BUDZ!(X]"")
QUIT
Begin DoDot:1
+12 SET X=$$ANNECONT(P,BUDZ,EDATE)
End DoDot:1
+13 IF X]""
QUIT "1^IPV: CONTRA IMM package: "_$$DATE^BUDHUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+14 SET T=$ORDER(^BUDHTSSC("B","T6B IMM IPV CODES",0))
+15 SET BUDZ=0
FOR
SET BUDZ=$ORDER(^BUDHTSSC(T,15,"B",BUDZ))
IF BUDZ'=+BUDZ!(X]"")
QUIT
Begin DoDot:1
+16 SET X=$$MMRCONT(P,BUDZ,EDATE)
End DoDot:1
+17 IF X]""
QUIT "1^IPV: CONTRA IMM package: "_$$DATE^BUDHUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+18 ;ALL VACCINE CONTRA
+19 SET X=$$CONTRA(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDHTSSC("B","T6B IMM IPV CODES",0)),"IPV")
+20 IF X]""
QUIT X
+21 ;now check snomed contra codes
+22 ;SNOMED ANALPHALACTIC V POV OR PROBLEM LIST?
+23 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA IPV",0))
+24 SET (X,Y,I)=0
+25 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+26 IF '$DATA(^AUPNPROB(X,0))
QUIT
+27 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+28 ;if there is a doo and it is after report period skip
IF $PIECE(^AUPNPROB(X,0),U,13)
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+29 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+30 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+31 IF S]""
IF $DATA(^BUDHTSSC("AS",S,T))
SET I="1^IPV: CONTRA PL "_S
QUIT
+32 QUIT
End DoDot:1
+33 IF I
QUIT I
+34 ;NOW V POV SNOMED
+35 SET G=""
SET I=""
+36 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+37 SET I=0
+38 IF $DATA(^BUDHTSSC("AS",S,T))
SET I="1^IPV: CONTRA POV "_S
+39 IF 'I
QUIT
+40 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+41 SET Y=9999999-D
+42 IF Y>EDATE
QUIT
+43 SET G=I_"^"_$$DATE^BUDHUTL1(Y)
End DoDot:2
End DoDot:1
+44 IF G
QUIT G
IPVEVID ;
+1 ;NOW EVIDENCE OF DISEASE
+2 SET G=$$PLTAXND^BUDHDU(P,"BUD 18 IPV EVIDENCE",EDATE,0)
IF G
QUIT "1^IPV: EVID PL "_$PIECE(G,U,2)_" on "_$$DATE^BUDHUTL1($PIECE(G,U,3))
+3 SET G=$$LASTDX^BUDHUTL1(P,"BUD 18 IPV EVIDENCE",$$DOB^AUPNPAT(P),EDATE)
IF G
QUIT "1^IPV: EVID DX "_$PIECE(G,U,2)_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U,3))
+4 KILL BUDD,BUDG,BUDX
+5 KILL BUDOPV,BUDAPOV
IPVIMM ;get all immunizations
+1 SET BUDOPV=0
+2 ;all visits in 42 days to end
DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+3 SET TIEN=$ORDER(^BUDHTSSC("B","T6B IMM IPV CODES",0))
+4 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+5 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+6 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVIMM(X,0))
QUIT
+9 SET Y=$$VALI^XBDIQ1(9000010.11,X,.01)
+10 SET Y=+$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+11 IF 'Y
QUIT
+12 IF $DATA(^BUDHTSSC(TIEN,15,"B",Y))
SET BUDOPV(VDATE)="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+13 ;CPT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+15 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+16 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+17 IF Y=""
QUIT
+18 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
SET BUDOPV(VDATE)="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+19 ;V TRANS
+20 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+21 IF '$DATA(^AUPNVTC(X,0))
QUIT
+22 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+23 IF Y=""
QUIT
+24 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
SET BUDOPV(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+25 ;V PROC
+26 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+28 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+29 IF $DATA(^BUDHTSSC("AP",Y,TIEN))
SET BUDOPV(VDATE)="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+30 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+31 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+32 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+33 IF Y=""
QUIT
+34 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDOPV(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
End DoDot:1
+35 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+36 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+37 IF C=1
SET Y=X
QUIT
+38 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDOPV(X)
QUIT
+39 SET Y=X
End DoDot:1
+40 ;now count them and see if there are 3 of them
+41 SET BUDOPV=0
SET X=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET BUDOPV=BUDOPV+1
+42 IF BUDOPV>2
SET Y="1^IPV: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+43 IF BUDOPV>2
QUIT Y
+44 QUIT "0^"_(3-BUDOPV)_" IPV"
+45 ;
ANALCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRA
+1 NEW X,G,D,R,Y
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 ;Q:$P(^BIPC(X,0),U,4)>ED
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Anaphylaxis"
End DoDot:1
+11 QUIT G
+12 ;
