BGP2D33 ; IHS/CMI/LAB - measure C ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
OPV(P,EDATE) ;EP
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPOPV,BGPAPOV
;get all immunizations
S C="2^89^10^110^120^130^132^146"
K BGPX D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
;go through and set into array if 10 days apart
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPOPV(X)="",BGPAPOV(X)=""
;now get cpts
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90712!(Y=90698)!(Y=90711)!(Y=90713)!(Y=90723)!(Y=90696) S BGPOPV(9999999-$P(ED,"."))="",BGPAPOV(9999999-$P(ED,"."))=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90712!(Y=90698)!(Y=90711)!(Y=90713)!(Y=90723)!(Y=90696) S BGPOPV(9999999-$P(ED,"."))="",BGPAPOV(9999999-$P(ED,"."))=""
;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(BGPOPV(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPOPV(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPOPV=0,X=0 F S X=$O(BGPOPV(X)) Q:X'=+X S BGPOPV=BGPOPV+1
I BGPOPV>2 Q 1_U_"3 Polio"
;now get povs
K BGPPOV M BGPPOV=BGPAPOV
K BGPG S %=P_"^ALL DX [BGP IPV IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPOPV($P(BGPG(X),U))="",BGPAOPV($P(BGPG(X),U))=""
K BGPG D SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP IPV IZ PROCS",.BGPG)
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPOPV($P(BGPG(X),U))="",BGPAPOV($P(BGPG(X),U))=""
;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(BGPOPV(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPOPV(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPOPV=0,X=0 F S X=$O(BGPOPV(X)) Q:X'=+X S BGPOPV=BGPOPV+1
I BGPOPV>2 Q 2_U_"3 Polio"
;check for Evidence of desease and Contraindications and if yes, then quit
K BGPG S %=P_"^LAST DX [BGP OPV EVID DISEASE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 4_U_"Evid Polio"
I $$PLTAX^BGP2DU(P,"BGP OPV EVID DISEASE") Q 4_U_"Evid Polio"
K BGPG S %=P_"^LAST DX [BGP OPV CONTRAINDICATIONS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 4_U_"Contra Polio"
I $$PLTAX^BGP2DU(P,"BGP OPV CONTRAINDICATONS") Q 4_U_"Contra Polio"
F BGPZ=2,89 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra Polio"
F BGPZ=10,89,110,120,130,132,146 S X=$$ANNECONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra Polio"
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=2,89,10,110,120,130,132,146 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Polio",1:"Ref Polio")
F BGPIMM=90712,90696,90698,90711,90713,90723 D
.S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Polio",1:"Ref Polio")
;now check Refusals in imm pkg
F BGPIMM=2,89,10,110,120,130,132,146 S R=$$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q 3_U_"Ref Polio"
Q ""
MMR(P,EDATE) ;EP
K BGPC,BGPG,BGPX
K ^TMP($J,"CPT")
;first gather up all cpt codes that relate in any way to dtap and store in ^TMP
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=+Y,$T(@Y)]"" S ^TMP($J,"CPT",9999999-$P(ED,"."),Y)=""
S BGPMMR=0
;get all immunizations
S C="3^94"
K BGPX D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
I $D(BGPX) Q 1_U_"MMR"
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90707!(Y=90710) S BGPMMR=1
I BGPMMR Q 1_U_"MMR"
MR ;see if one M/R, Mumps or R/M
S (BGPMR,BGPRM,BGPME,BGPMU,BGPRUB)=0
S C=4
K BGPX D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
I $D(BGPX) S BGPMR=1
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90708 S BGPMR=1
RM ;
S C=38
D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
I $D(BGPX) S BGPRM=1
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90709 S BGPRM=1
ME S C=5
K BGPX D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
I $D(BGPX) S BGPME=1
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90705 S BGPME=1
MU S C=7
D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
I $D(BGPX) S BGPMU=1
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90704 S BGPMU=1
RUB S C=6
D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
I $D(BGPX) S BGPRUB=1
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90706 S BGPRUB=1
I BGPMR,BGPMU Q 1_U_"m/r mu"
I BGPRM,BGPME Q 1_U_"r/m me"
I BGPME,BGPMU,BGPRUB Q 1_U_"me mu rub"
;now add diagnoses and proc codes for code 2
PVS ;
K BGPG S %=P_"^ALL DX [BGP MMR IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 2_U_"MMR"
K BGPG S BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP MMR IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
I BGPG(1)]"" Q 2_U_"MMR"
MEPV ;
K BGPG S %=P_"^ALL DX [BGP MEASLES IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPME=1
K BGPG S BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP MEASLES IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
I BGPG(1)]"" S BGPME=1
MUPV ;
K BGPG S %=P_"^ALL DX [BGP MUMPS IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPMU=1
K BGPG S BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP MUMPS IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
I BGPG(1)]"" S BGPMU=1
RUBPV ;
K BGPG S %=P_"^ALL DX [BGP RUBELLA IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPRUB=1
K BGPG S BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP RUBELLA IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
I BGPG(1)]"" S BGPRUB=1
I BGPMR,BGPMU Q 2_U_"m/r mu"
I BGPRM,BGPME Q 2_U_"r/m me"
I BGPME,BGPMU,BGPRUB Q 2_U_"me mu rub"
REF ;
;now get a Refusal of MMR if there is one
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",BGPMMR=0,R=""
F BGPIMM=3,94 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI MMR",1:"Ref MMR")
F BGPIMM=90707,90710 D
.S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI MMR",1:"Ref MMR")
;now check Refusals in imm pkg
S R="" F BGPIMM=3,94 S R=$$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q 3_U_"Ref MMR"
MMRC K BGPG S %=P_"^LAST DX [BGP MMR CONTRAINDICATIONS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 4_U_"Contra MMR"
I $$PLTAX^BGP2DU(P,"BGP MMR CONTRAINDICATIONS") Q 4_U_"Contra MMR"
F BGPZ=3,94 S X=$$MMRCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra MMR"
MRC ;
F BGPZ=4 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra MR"
REFMR ;
I BGPMR=0 D
.S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI=""
.F BGPIMM=4 D
..S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
..S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S BGPMR=$S($P(^AUPNPREF(Y,0),U,7)="N":4,1:3)
.F BGPIMM=90708 D
..S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
..S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S BGPMR=$S($P(^AUPNPREF(Y,0),U,7)="N":4,1:3)
;now check Refusals in imm pkg
F BGPIMM=4 I $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMR=3
RMC ;
F BGPZ=38 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra RM"
REFRM I BGPRM=0 D
.S B=$$DOB^AUPNPAT(P),E=EDATE
.F BGPIMM=38 D
..S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
..S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S BGPRM=$S($P(^AUPNPREF(Y,0),U,7)="N":4,1:3)
.F BGPIMM=90709 D
..S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
..S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S BGPRM=$S($P(^AUPNPREF(Y,0),U,7)="N":4,1:3)
F BGPIMM=38 I $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPRM=3
MEX ;
I BGPME=0 K BGPG S %=P_"^LAST DX [BGP MEASLES EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(") I $D(BGPG(1)) S BGPME=1
I $$PLTAX^BGP2DU(P,"BGP MEASLES EVIDENCE") S BGPME=1
I BGPME=0 D
.S B=$$DOB^AUPNPAT(P),E=EDATE
.F BGPIMM=5 D
..S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
..S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S BGPME=$S($P(^AUPNPREF(Y,0),U,7)="N":4,1:3)
.F BGPIMM=90705 D
..S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
..S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S BGPME=$S($P(^AUPNPREF(Y,0),U,7)="N":4,1:3)
F BGPIMM=7 I $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPME=3
F BGPZ=5 S X=$$MMRCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
I X]"" S BGPME=4
MUX ;
I BGPMU=0 K BGPG S %=P_"^LAST DX [BGP MUMPS EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(") I $D(BGPG(1)) S BGPMU=1
I $$PLTAX^BGP2DU(P,"BGP MUMPS EVIDENCE") S BGPMU=1
I BGPMU=0 D
.S B=$$DOB^AUPNPAT(P),E=EDATE
.F BGPIMM=7 D
..S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
..S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S BGPMU=$S($P(^AUPNPREF(Y,0),U,7)="N":4,1:3)
.F BGPIMM=90704 D
..S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
..S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S BGPMU=$S($P(^AUPNPREF(Y,0),U,7)="N":4,1:3)
;now check Refusals in imm pkg
F BGPIMM="7" I $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMU=3
F BGPZ=7 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
I X]"" S BGPMU=4
RUBX ;
I BGPRUB=0 K BGPG S %=P_"^LAST DX [BGP RUBELLA EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(") I $D(BGPG(1)) S BGPRUB=1
I $$PLTAX^BGP2DU(P,"BGP RUBELLA EVIDENCE") S BGPRUB=1
I BGPRUB=0 D
.S B=$$DOB^AUPNPAT(P),E=EDATE
.F BGPIMM=6 D
..S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
..S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S BGPRUB=$S($P(^AUPNPREF(Y,0),U,7)="N":4,1:3)
.F BGPIMM=90706 D
..S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
..S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S BGPRUB=$S($P(^AUPNPREF(Y,0),U,7)="N":4,1:3)
F BGPIMM=6 I $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPRUB=3
F BGPZ=6 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
I X]"" S BGPRUB=4
I BGPMR,BGPMU S X=1 S:BGPMR=3 X=3 S:BGPMU=3 X=3 S:BGPMR=4 X=4 S:BGPMU=4 X=4 Q X_U_$S(X=4:" NMI",X=3:" Ref",1:"")_" MR & MU"
I BGPRM,BGPME S X=1 S:BGPRM=3 X=3 S:BGPME=3 X=3 S:BGPRM=4 X=4 S:BGPME=4 X=4 Q X_U_$S(X=4:" NMI",X=3:" Ref",1:"")_" RM & ME"
I BGPME,BGPMU,BGPRUB S X=1 S:BGPME=3 X=3 S:BGPMU=3 X=3 S:BGPRUB=3 X=3 S:BGPME=4 X=4 S:BGPMU=4 X=4 S:BGPRUB=4 X=4 Q X_U_$S(X=4:" NMI",X=3:" Ref",1:"")_" ME&MU&RUB" ;_$S(X=4:" NMI",X=3:" Ref",1:"")
Q ""
90707 ;;
90710 ;;
90708 ;;
90709 ;;
90705 ;;
90704 ;;
90706 ;;
BGP2D33 ; IHS/CMI/LAB - measure C ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
OPV(P,EDATE) ;EP
+1 KILL BGPC,BGPG,BGPX
+2 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+3 KILL BGPOPV,BGPAPOV
+4 ;get all immunizations
+5 SET C="2^89^10^110^120^130^132^146"
+6 KILL BGPX
DO GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
+7 ;go through and set into array if 10 days apart
+8 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPOPV(X)=""
SET BGPAPOV(X)=""
+9 ;now get cpts
+10 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+11 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+12 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90712!(Y=90698)!(Y=90711)!(Y=90713)!(Y=90723)!(Y=90696)
SET BGPOPV(9999999-$PIECE(ED,"."))=""
SET BGPAPOV(9999999-$PIECE(ED,"."))=""
End DoDot:3
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90712!(Y=90698)!(Y=90711)!(Y=90713)!(Y=90723)!(Y=90696)
SET BGPOPV(9999999-$PIECE(ED,"."))=""
SET BGPAPOV(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+19 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+20 IF C=1
SET Y=X
QUIT
+21 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPOPV(X)
QUIT
+22 SET Y=X
End DoDot:1
+23 ;now count them and see if there are 4 of them
+24 SET BGPOPV=0
SET X=0
FOR
SET X=$ORDER(BGPOPV(X))
IF X'=+X
QUIT
SET BGPOPV=BGPOPV+1
+25 IF BGPOPV>2
QUIT 1_U_"3 Polio"
+26 ;now get povs
+27 KILL BGPPOV
MERGE BGPPOV=BGPAPOV
+28 KILL BGPG
SET %=P_"^ALL DX [BGP IPV IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+29 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPOPV($PIECE(BGPG(X),U))=""
SET BGPAOPV($PIECE(BGPG(X),U))=""
+30 KILL BGPG
DO SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP IPV IZ PROCS",.BGPG)
+31 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPOPV($PIECE(BGPG(X),U))=""
SET BGPAPOV($PIECE(BGPG(X),U))=""
+32 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+33 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+34 IF C=1
SET Y=X
QUIT
+35 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPOPV(X)
QUIT
+36 SET Y=X
End DoDot:1
+37 ;now count them and see if there are 4 of them
+38 SET BGPOPV=0
SET X=0
FOR
SET X=$ORDER(BGPOPV(X))
IF X'=+X
QUIT
SET BGPOPV=BGPOPV+1
+39 IF BGPOPV>2
QUIT 2_U_"3 Polio"
+40 ;check for Evidence of desease and Contraindications and if yes, then quit
+41 KILL BGPG
SET %=P_"^LAST DX [BGP OPV EVID DISEASE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+42 IF $DATA(BGPG(1))
QUIT 4_U_"Evid Polio"
+43 IF $$PLTAX^BGP2DU(P,"BGP OPV EVID DISEASE")
QUIT 4_U_"Evid Polio"
+44 KILL BGPG
SET %=P_"^LAST DX [BGP OPV CONTRAINDICATIONS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+45 IF $DATA(BGPG(1))
QUIT 4_U_"Contra Polio"
+46 IF $$PLTAX^BGP2DU(P,"BGP OPV CONTRAINDICATONS")
QUIT 4_U_"Contra Polio"
+47 FOR BGPZ=2,89
SET X=$$ANCONT^BGP2D31(P,BGPZ,EDATE)
IF X]""
QUIT
+48 IF X]""
QUIT 4_U_"Contra Polio"
+49 FOR BGPZ=10,89,110,120,130,132,146
SET X=$$ANNECONT^BGP2D31(P,BGPZ,EDATE)
IF X]""
QUIT
+50 IF X]""
QUIT 4_U_"Contra Polio"
+51 ;now go to Refusals
+52 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+53 FOR BGPIMM=2,89,10,110,120,130,132,146
Begin DoDot:1
+54 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+55 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+56 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Polio",1:"Ref Polio")
+57 FOR BGPIMM=90712,90696,90698,90711,90713,90723
Begin DoDot:1
+58 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+59 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+60 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Polio",1:"Ref Polio")
+61 ;now check Refusals in imm pkg
+62 FOR BGPIMM=2,89,10,110,120,130,132,146
SET R=$$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+63 IF R
QUIT 3_U_"Ref Polio"
+64 QUIT ""
MMR(P,EDATE) ;EP
+1 KILL BGPC,BGPG,BGPX
+2 KILL ^TMP($JOB,"CPT")
+3 ;first gather up all cpt codes that relate in any way to dtap and store in ^TMP
+4 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+5 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+6 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+10 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=+Y
IF $TEXT(@Y)]""
SET ^TMP($JOB,"CPT",9999999-$PIECE(ED,"."),Y)=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET BGPMMR=0
+12 ;get all immunizations
+13 SET C="3^94"
+14 KILL BGPX
DO GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
+15 IF $DATA(BGPX)
QUIT 1_U_"MMR"
+16 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+17 IF Y=90707!(Y=90710)
SET BGPMMR=1
End DoDot:1
+18 IF BGPMMR
QUIT 1_U_"MMR"
MR ;see if one M/R, Mumps or R/M
+1 SET (BGPMR,BGPRM,BGPME,BGPMU,BGPRUB)=0
+2 SET C=4
+3 KILL BGPX
DO GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
+4 IF $DATA(BGPX)
SET BGPMR=1
+5 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+6 IF Y=90708
SET BGPMR=1
End DoDot:1
RM ;
+1 SET C=38
+2 DO GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
+3 IF $DATA(BGPX)
SET BGPRM=1
+4 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+5 IF Y=90709
SET BGPRM=1
End DoDot:1
ME SET C=5
+1 KILL BGPX
DO GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
+2 IF $DATA(BGPX)
SET BGPME=1
+3 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+4 IF Y=90705
SET BGPME=1
End DoDot:1
MU SET C=7
+1 DO GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
+2 IF $DATA(BGPX)
SET BGPMU=1
+3 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+4 IF Y=90704
SET BGPMU=1
End DoDot:1
RUB SET C=6
+1 DO GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
+2 IF $DATA(BGPX)
SET BGPRUB=1
+3 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+4 IF Y=90706
SET BGPRUB=1
End DoDot:1
+5 IF BGPMR
IF BGPMU
QUIT 1_U_"m/r mu"
+6 IF BGPRM
IF BGPME
QUIT 1_U_"r/m me"
+7 IF BGPME
IF BGPMU
IF BGPRUB
QUIT 1_U_"me mu rub"
+8 ;now add diagnoses and proc codes for code 2
PVS ;
+1 KILL BGPG
SET %=P_"^ALL DX [BGP MMR IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
QUIT 2_U_"MMR"
+3 KILL BGPG
SET BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP MMR IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
+4 IF BGPG(1)]""
QUIT 2_U_"MMR"
MEPV ;
+1 KILL BGPG
SET %=P_"^ALL DX [BGP MEASLES IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET BGPME=1
+3 KILL BGPG
SET BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP MEASLES IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
+4 IF BGPG(1)]""
SET BGPME=1
MUPV ;
+1 KILL BGPG
SET %=P_"^ALL DX [BGP MUMPS IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET BGPMU=1
+3 KILL BGPG
SET BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP MUMPS IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
+4 IF BGPG(1)]""
SET BGPMU=1
RUBPV ;
+1 KILL BGPG
SET %=P_"^ALL DX [BGP RUBELLA IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET BGPRUB=1
+3 KILL BGPG
SET BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP RUBELLA IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
+4 IF BGPG(1)]""
SET BGPRUB=1
+5 IF BGPMR
IF BGPMU
QUIT 2_U_"m/r mu"
+6 IF BGPRM
IF BGPME
QUIT 2_U_"r/m me"
+7 IF BGPME
IF BGPMU
IF BGPRUB
QUIT 2_U_"me mu rub"
REF ;
+1 ;now get a Refusal of MMR if there is one
+2 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET BGPMMR=0
SET R=""
+3 FOR BGPIMM=3,94
Begin DoDot:1
+4 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+6 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI MMR",1:"Ref MMR")
+7 FOR BGPIMM=90707,90710
Begin DoDot:1
+8 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+9 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+10 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI MMR",1:"Ref MMR")
+11 ;now check Refusals in imm pkg
+12 SET R=""
FOR BGPIMM=3,94
SET R=$$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+13 IF R
QUIT 3_U_"Ref MMR"
MMRC KILL BGPG
SET %=P_"^LAST DX [BGP MMR CONTRAINDICATIONS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+1 IF $DATA(BGPG(1))
QUIT 4_U_"Contra MMR"
+2 IF $$PLTAX^BGP2DU(P,"BGP MMR CONTRAINDICATIONS")
QUIT 4_U_"Contra MMR"
+3 FOR BGPZ=3,94
SET X=$$MMRCONT^BGP2D31(P,BGPZ,EDATE)
IF X]""
QUIT
+4 IF X]""
QUIT 4_U_"Contra MMR"
MRC ;
+1 FOR BGPZ=4
SET X=$$ANCONT^BGP2D31(P,BGPZ,EDATE)
IF X]""
QUIT
+2 IF X]""
QUIT 4_U_"Contra MR"
REFMR ;
+1 IF BGPMR=0
Begin DoDot:1
+2 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
+3 FOR BGPIMM=4
Begin DoDot:2
+4 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET BGPMR=$SELECT($PIECE(^AUPNPREF(Y,0),U,7)="N":4,1:3)
End DoDot:2
+6 FOR BGPIMM=90708
Begin DoDot:2
+7 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+8 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET BGPMR=$SELECT($PIECE(^AUPNPREF(Y,0),U,7)="N":4,1:3)
End DoDot:2
End DoDot:1
+9 ;now check Refusals in imm pkg
+10 FOR BGPIMM=4
IF $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPMR=3
RMC ;
+1 FOR BGPZ=38
SET X=$$ANCONT^BGP2D31(P,BGPZ,EDATE)
IF X]""
QUIT
+2 IF X]""
QUIT 4_U_"Contra RM"
REFRM IF BGPRM=0
Begin DoDot:1
+1 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
+2 FOR BGPIMM=38
Begin DoDot:2
+3 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+4 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET BGPRM=$SELECT($PIECE(^AUPNPREF(Y,0),U,7)="N":4,1:3)
End DoDot:2
+5 FOR BGPIMM=90709
Begin DoDot:2
+6 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET BGPRM=$SELECT($PIECE(^AUPNPREF(Y,0),U,7)="N":4,1:3)
End DoDot:2
End DoDot:1
+8 FOR BGPIMM=38
IF $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPRM=3
MEX ;
+1 IF BGPME=0
KILL BGPG
SET %=P_"^LAST DX [BGP MEASLES EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
IF $DATA(BGPG(1))
SET BGPME=1
+2 IF $$PLTAX^BGP2DU(P,"BGP MEASLES EVIDENCE")
SET BGPME=1
+3 IF BGPME=0
Begin DoDot:1
+4 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
+5 FOR BGPIMM=5
Begin DoDot:2
+6 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET BGPME=$SELECT($PIECE(^AUPNPREF(Y,0),U,7)="N":4,1:3)
End DoDot:2
+8 FOR BGPIMM=90705
Begin DoDot:2
+9 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET BGPME=$SELECT($PIECE(^AUPNPREF(Y,0),U,7)="N":4,1:3)
End DoDot:2
End DoDot:1
+11 FOR BGPIMM=7
IF $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPME=3
+12 FOR BGPZ=5
SET X=$$MMRCONT^BGP2D31(P,BGPZ,EDATE)
IF X]""
QUIT
+13 IF X]""
SET BGPME=4
MUX ;
+1 IF BGPMU=0
KILL BGPG
SET %=P_"^LAST DX [BGP MUMPS EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
IF $DATA(BGPG(1))
SET BGPMU=1
+2 IF $$PLTAX^BGP2DU(P,"BGP MUMPS EVIDENCE")
SET BGPMU=1
+3 IF BGPMU=0
Begin DoDot:1
+4 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
+5 FOR BGPIMM=7
Begin DoDot:2
+6 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET BGPMU=$SELECT($PIECE(^AUPNPREF(Y,0),U,7)="N":4,1:3)
End DoDot:2
+8 FOR BGPIMM=90704
Begin DoDot:2
+9 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET BGPMU=$SELECT($PIECE(^AUPNPREF(Y,0),U,7)="N":4,1:3)
End DoDot:2
End DoDot:1
+11 ;now check Refusals in imm pkg
+12 FOR BGPIMM="7"
IF $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPMU=3
+13 FOR BGPZ=7
SET X=$$ANCONT^BGP2D31(P,BGPZ,EDATE)
IF X]""
QUIT
+14 IF X]""
SET BGPMU=4
RUBX ;
+1 IF BGPRUB=0
KILL BGPG
SET %=P_"^LAST DX [BGP RUBELLA EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
IF $DATA(BGPG(1))
SET BGPRUB=1
+2 IF $$PLTAX^BGP2DU(P,"BGP RUBELLA EVIDENCE")
SET BGPRUB=1
+3 IF BGPRUB=0
Begin DoDot:1
+4 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
+5 FOR BGPIMM=6
Begin DoDot:2
+6 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET BGPRUB=$SELECT($PIECE(^AUPNPREF(Y,0),U,7)="N":4,1:3)
End DoDot:2
+8 FOR BGPIMM=90706
Begin DoDot:2
+9 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET BGPRUB=$SELECT($PIECE(^AUPNPREF(Y,0),U,7)="N":4,1:3)
End DoDot:2
End DoDot:1
+11 FOR BGPIMM=6
IF $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPRUB=3
+12 FOR BGPZ=6
SET X=$$ANCONT^BGP2D31(P,BGPZ,EDATE)
IF X]""
QUIT
+13 IF X]""
SET BGPRUB=4
+14 IF BGPMR
IF BGPMU
SET X=1
IF BGPMR=3
SET X=3
IF BGPMU=3
SET X=3
IF BGPMR=4
SET X=4
IF BGPMU=4
SET X=4
QUIT X_U_$SELECT(X=4:" NMI",X=3:" Ref",1:"")_" MR & MU"
+15 IF BGPRM
IF BGPME
SET X=1
IF BGPRM=3
SET X=3
IF BGPME=3
SET X=3
IF BGPRM=4
SET X=4
IF BGPME=4
SET X=4
QUIT X_U_$SELECT(X=4:" NMI",X=3:" Ref",1:"")_" RM & ME"
+16 ;_$S(X=4:" NMI",X=3:" Ref",1:"")
IF BGPME
IF BGPMU
IF BGPRUB
SET X=1
IF BGPME=3
SET X=3
IF BGPMU=3
SET X=3
IF BGPRUB=3
SET X=3
IF BGPME=4
SET X=4
IF BGPMU=4
SET X=4
IF BGPRUB=4
SET X=4
QUIT X_U_$SELECT(X=4:" NMI",X=3:" Ref",1:"")_" ME&MU&RUB"
+17 QUIT ""
90707 ;;
90710 ;;
90708 ;;
90709 ;;
90705 ;;
90704 ;;
90706 ;;
