Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP9D33

BGP9D33.m

Go to the documentation of this file.
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 ;;