- 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 ;;