BGP9D33 ; IHS/CMI/LAB - measure C ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
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"
K BGPX D GETIMMS^BGP9D32(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 OPV"
;now get povs
K BGPPOV M BGPPOV=BGPAPOV
K BGPG S %=P_"^ALL DX V06.3;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 S %=P_"^ALL DX V04.0;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 S %=P_"^ALL PROCEDURE 99.41;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))="",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 OPV"
;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 opv"
I $$PLTAX^BGP9DU(P,"BGP OPV EVID DISEASE") Q 4_U_"evid opv"
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 opv"
I $$PLTAX^BGP9DU(P,"BGP OPV CONTRAINDICATONS") Q 4_U_"contra opv"
F BGPZ=2,89 S X=$$ANCONT^BGP9D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra - OPV"
F BGPZ=10,89,110,120,130 S X=$$ANNECONT^BGP9D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra - IPV"
;now go to refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=2,89,10,110,120,130 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 OPV",1:"ref OPV")
;now check refusals in imm pkg
F BGPIMM=2,89,10,110,120 S R=$$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q 3_U_"ref OPV"
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^BGP9D32(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^BGP9D32(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^BGP9D32(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^BGP9D32(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^BGP9D32(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^BGP9D32(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 V06.4;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 2_U_"MMR"
K BGPG S %=P_"^ALL PROCEDURE 99.48;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 2_U_"MMR"
MEPV ;
K BGPG S %=P_"^ALL DX V04.2;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPME=1
K BGPG S %=P_"^ALL PROCEDURE 99.45;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPME=1
MUPV ;
K BGPG S %=P_"^ALL DX V04.6;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPMU=1
K BGPG S %=P_"^ALL PROCEDURE 99.46;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPMU=1
RUBPV ;
K BGPG S %=P_"^ALL DX V04.3;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPRUB=1
K BGPG S %=P_"^ALL PROCEDURE 99.47;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(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")
;now check refusals in imm pkg
S R="" F BGPIMM=3,94 S R=$$IMMREF^BGP9D32(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^BGP9DU(P,"BGP MMR CONTRAINDICATIONS") Q 4_U_"contra MMR"
F BGPZ=3,94 S X=$$MMRCONT^BGP9D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra mmr"
MRC ;
F BGPZ=4 S X=$$ANCONT^BGP9D31(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)
;now check refusals in imm pkg
F BGPIMM=4 I $$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMR=3
RMC ;
F BGPZ=38 S X=$$ANCONT^BGP9D31(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=38 I $$IMMREF^BGP9D32(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^BGP9DU(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=7 I $$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPME=3
F BGPZ=5 S X=$$MMRCONT^BGP9D31(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^BGP9DU(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)
;now check refusals in imm pkg
F BGPIMM="7" I $$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMU=3
F BGPZ=7 S X=$$ANCONT^BGP9D31(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^BGP9DU(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=6 I $$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPRUB=3
F BGPZ=6 S X=$$ANCONT^BGP9D31(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_"mr & mu"_$S(X=4:" NMI",X=3:" ref",1:"")
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_"RM & ME"_$S(X=4:" NMI",X=3:" ref",1:"")
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_"ME&MU&RUB"_$S(X=4:" NMI",X=3:" ref",1:"")
Q ""
90707 ;;
90710 ;;
90708 ;;
90709 ;;
90705 ;;
90704 ;;
90706 ;;
BGP9D33 ; IHS/CMI/LAB - measure C ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+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"
+6 KILL BGPX
DO GETIMMS^BGP9D32(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 OPV"
+26 ;now get povs
+27 KILL BGPPOV
MERGE BGPPOV=BGPAPOV
+28 KILL BGPG
SET %=P_"^ALL DX V06.3;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
SET %=P_"^ALL DX V04.0;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"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 BGPAOPV($PIECE(BGPG(X),U))=""
+32 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.41;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+33 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))=""
+34 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+35 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+36 IF C=1
SET Y=X
QUIT
+37 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPOPV(X)
QUIT
+38 SET Y=X
End DoDot:1
+39 ;now count them and see if there are 4 of them
+40 SET BGPOPV=0
SET X=0
FOR
SET X=$ORDER(BGPOPV(X))
IF X'=+X
QUIT
SET BGPOPV=BGPOPV+1
+41 IF BGPOPV>2
QUIT 2_U_"3 OPV"
+42 ;check for evidence of desease and contraindications and if yes, then quit
+43 KILL BGPG
SET %=P_"^LAST DX [BGP OPV EVID DISEASE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+44 IF $DATA(BGPG(1))
QUIT 4_U_"evid opv"
+45 IF $$PLTAX^BGP9DU(P,"BGP OPV EVID DISEASE")
QUIT 4_U_"evid opv"
+46 KILL BGPG
SET %=P_"^LAST DX [BGP OPV CONTRAINDICATIONS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+47 IF $DATA(BGPG(1))
QUIT 4_U_"contra opv"
+48 IF $$PLTAX^BGP9DU(P,"BGP OPV CONTRAINDICATONS")
QUIT 4_U_"contra opv"
+49 FOR BGPZ=2,89
SET X=$$ANCONT^BGP9D31(P,BGPZ,EDATE)
IF X]""
QUIT
+50 IF X]""
QUIT 4_U_"contra - OPV"
+51 FOR BGPZ=10,89,110,120,130
SET X=$$ANNECONT^BGP9D31(P,BGPZ,EDATE)
IF X]""
QUIT
+52 IF X]""
QUIT 4_U_"contra - IPV"
+53 ;now go to refusals
+54 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+55 FOR BGPIMM=2,89,10,110,120,130
Begin DoDot:1
+56 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+57 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
+58 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI OPV",1:"ref OPV")
+59 ;now check refusals in imm pkg
+60 FOR BGPIMM=2,89,10,110,120
SET R=$$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+61 IF R
QUIT 3_U_"ref OPV"
+62 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^BGP9D32(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^BGP9D32(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^BGP9D32(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^BGP9D32(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^BGP9D32(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^BGP9D32(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 V06.4;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
QUIT 2_U_"MMR"
+3 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.48;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT 2_U_"MMR"
MEPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V04.2;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET BGPME=1
+3 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.45;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET BGPME=1
MUPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V04.6;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET BGPMU=1
+3 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.46;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET BGPMU=1
RUBPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V04.3;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET BGPRUB=1
+3 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.47;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(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 ;now check refusals in imm pkg
+8 SET R=""
FOR BGPIMM=3,94
SET R=$$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+9 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^BGP9DU(P,"BGP MMR CONTRAINDICATIONS")
QUIT 4_U_"contra MMR"
+3 FOR BGPZ=3,94
SET X=$$MMRCONT^BGP9D31(P,BGPZ,EDATE)
IF X]""
QUIT
+4 IF X]""
QUIT 4_U_"contra mmr"
MRC ;
+1 FOR BGPZ=4
SET X=$$ANCONT^BGP9D31(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
End 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:1
+6 ;now check refusals in imm pkg
+7 FOR BGPIMM=4
IF $$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPMR=3
RMC ;
+1 FOR BGPZ=38
SET X=$$ANCONT^BGP9D31(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
End 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:1
+5 FOR BGPIMM=38
IF $$IMMREF^BGP9D32(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^BGP9DU(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
End 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:1
+8 FOR BGPIMM=7
IF $$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPME=3
+9 FOR BGPZ=5
SET X=$$MMRCONT^BGP9D31(P,BGPZ,EDATE)
IF X]""
QUIT
+10 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^BGP9DU(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
End 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:1
+8 ;now check refusals in imm pkg
+9 FOR BGPIMM="7"
IF $$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPMU=3
+10 FOR BGPZ=7
SET X=$$ANCONT^BGP9D31(P,BGPZ,EDATE)
IF X]""
QUIT
+11 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^BGP9DU(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
End 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:1
+8 FOR BGPIMM=6
IF $$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPRUB=3
+9 FOR BGPZ=6
SET X=$$ANCONT^BGP9D31(P,BGPZ,EDATE)
IF X]""
QUIT
+10 IF X]""
SET BGPRUB=4
+11 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_"mr & mu"_$SELECT(X=4:" NMI",X=3:" ref",1:"")
+12 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_"RM & ME"_$SELECT(X=4:" NMI",X=3:" ref",1:"")
+13 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_"ME&MU&RUB"_$SELECT(X=4:" NMI",X=3:" ref",1:"")
+14 QUIT ""
90707 ;;
90710 ;;
90708 ;;
90709 ;;
90705 ;;
90704 ;;
90706 ;;
