BGP1D85 ; IHS/CMI/LAB - measure C 09 Jun 2011 5:18 PM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
I28 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20)=0
S (BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27)=0
S (BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6)=0
S BGPVALUE=""
K BGPDTAP,BGPOPV,BGPMMR,BGPD,BGPT,BGPPER,BGPTET,BGPM,BGPMU,BGPME,BGPHIB,BGPHEP,BGPVAR
I 'BGPACTUP S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q ;must be active clinical
I $$AGE^AUPNPAT(DFN,BGPBDATE)<13 S BGPSTOP=1 Q ;not 13 at beginning of time period
I $$AGE^AUPNPAT(DFN,BGPBDATE)>17 S BGPSTOP=1 Q
I $$AGE^AUPNPAT(DFN,BGPBDATE)=13 S BGPD1=1 I BGPSEX="F" S BGPD3=1
S BGPD2=1
I BGPSEX="F" S BGPD4=1
K ^TMP($J,"CPT")
S BGPVAL=$$TDAP^BGP1D86(DFN,BGPEDATE)
I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN10=1 ;any hit
I $P(BGPVAL,U,1)=3 S BGPN11=1
I $P(BGPVAL,U,1)=4 S BGPN12=1 ;evid disease, nmi, contraindication
I $P(BGPVAL,U,2)["Tdap" S BGPN6=1 ;tdap
I $P(BGPVAL,U,1) S BGPVALUE=$P(BGPVAL,U,2)
S BGPVAL=$$MMR(DFN,BGPEDATE)
I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN7=1 ;any hit
I $P(BGPVAL,U,1)=3 S BGPN8=1
I $P(BGPVAL,U,1)=4 S BGPN9=1 ;evid disease, nmi, contraindication
I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)
S BGPVAL=$$HEP^BGP1D35(DFN,BGPEDATE)
I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN13=1 ;any hit
I $P(BGPVAL,U,1)=3 S BGPN14=1
I $P(BGPVAL,U,1)=4 S BGPN15=1 ;evid disease, nmi, contraindication
I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)
S BGPVAL=$$VAR^BGP1D35(DFN,BGPEDATE)
I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN16=1 ;any hit
I $P(BGPVAL,U,1)=3 S BGPN17=1
I $P(BGPVAL,U,1)=4 S BGPN18=1 ;evid disease, nmi, contraindication
I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)
S BGPVAL=$$MEN^BGP1D36(DFN,BGPEDATE)
I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN1=1 ;any hit
I $P(BGPVAL,U,1)=3 S BGPN2=1
I $P(BGPVAL,U,1)=4 S BGPN3=1 ;evid disease, nmi, contraindication
I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)
S BGPVAL=$$HPV^BGP1D36(DFN,BGPEDATE)
I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN4=1 ;any hit
I $P(BGPVAL,U,1)=3 S BGPN5=1
I $P(BGPVAL,U,1)=4 S BGPN27=1 ;evid disease, nmi, contraindication
I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)
I BGPN7,BGPN13,BGPN16 S BGPN19=1 ;15.1.1
I BGPN8!(BGPN17)!(BGPN14) S BGPN22=1 ;15.1.2
I BGPN9!(BGPN18)!(BGPN15) S BGPN23=1 ;15.1.3
I BGPN7,BGPN13,BGPN16,BGPN10 S BGPN24=1 ;15.1.4
I BGPN8!(BGPN17)!(BGPN14)!(BGPN11) S BGPN25=1 ;15.1.5
I BGPN9!(BGPN18)!(BGPN15)!(BGPN12) S BGPN26=1 ;15.1.6
I BGPRTYPE=3,'BGPN19 S BGPVALUE="DID NOT HAVE: " D
.I 'BGPN7 S BGPVALUE=BGPVALUE_"2 MMR;"
.I 'BGPN13 S BGPVALUE=BGPVALUE_"3 HEP;"
.I 'BGPN16 S BGPVALUE=BGPVALUE_"VAR"
S D=""
S D="AC"
S BGPVALUE=D_"|||"_BGPVALUE
K BGPTET,BGPDTAP,BGPDT,BGPTD,BGPPER,BGPDIP,BGPMU,BGPME,BGPMMR,BGPMR,BGPRM,BGPOPV,BGPRUB,BGPHIB,BGPHEB,BGPVAR,BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6,BGPVAL
Q
IMMREF(P,IMM,BD,ED) ;EP
NEW X,Y,G,D,R
I 'IMM Q ""
S (X,G)=0,Y=$O(^AUTTIMM("C",IMM,0))
I 'Y Q ""
F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=G+1
Q G
MMR(P,EDATE) ;EP
K BGPC,BGPG,BGPX,BGPMMR
K ^TMP($J,"CPT")
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=+Y,$T(@Y)]"" S ^TMP($J,"CPT",9999999-ED,Y)=""
..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=+Y,$T(@Y)]"" S ^TMP($J,"CPT",9999999-ED,Y)=""
S BGPMMR=0
S C="3^94"
K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPMMR)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPMMR(X)=""
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(D)=""
S X="",Y="",C=0 F S X=$O(BGPMMR(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPMMR(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPMMR=0,X=0 F S X=$O(BGPMMR(X)) Q:X'=+X S BGPMMR=BGPMMR+1
I BGPMMR>1 Q 1_U_"2 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^BGP1D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPMR(X)=""
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(D)=""
;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(BGPMR(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPMR(X) Q
.S Y=X
;count them
S X=0 F S X=$O(BGPMR(X)) Q:X'=+X S BGPMR=BGPMR+1
RM ;
S C=38
K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPRM(X)=""
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(D)=""
;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(BGPRM(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPRM(X) Q
.S Y=X
;count them
S X=0 F S X=$O(BGPRM(X)) Q:X'=+X S BGPRM=BGPRM+1
ME S C=5
K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPME(X)=""
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(D)=""
;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(BGPME(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPME(X) Q
.S Y=X
;count them
S X=0 F S X=$O(BGPME(X)) Q:X'=+X S BGPME=BGPME+1
MU S C=7
K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPMU(X)=""
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(D)=""
;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(BGPMU(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPMU(X) Q
.S Y=X
;count them
S X=0 F S X=$O(BGPMU(X)) Q:X'=+X S BGPMU=BGPMU+1
RUB S C=6
K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPRUB(X)=""
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(D)=""
;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(BGPRUB(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPRUB(X) Q
.S Y=X
;count them
S X=0 F S X=$O(BGPRUB(X)) Q:X'=+X S BGPRUB=BGPRUB+1
I BGPMR>1,BGPMU>1 Q 1_U_"2 m/r 2 mu"
I BGPRM>1,BGPME>1 Q 1_U_"2 r/m 2 me"
I BGPME>1,BGPMU>1,BGPRUB>1 Q 1_U_"2 me 2 mu 2 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(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPMMR($P(BGPG(X),U))=""
S X="",Y="",C=0 F S X=$O(BGPMMR(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPMMR(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPMMR=0,X=0 F S X=$O(BGPMMR(X)) Q:X'=+X S BGPMMR=BGPMMR+1
I BGPMMR>1 Q 2_U_"2 MMR (DX/IMM)"
K BGPG S %=P_"^ALL PROCEDURE 99.48;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPMMR($P(BGPG(X),U))=""
S X="",Y="",C=0 F S X=$O(BGPMMR(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPMMR(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPMMR=0,X=0 F S X=$O(BGPMMR(X)) Q:X'=+X S BGPMMR=BGPMMR+1
I BGPMMR>1 Q 2_U_"2 MMR (PROC/IMM)"
MEPV ;
K BGPG S %=P_"^ALL DX V04.2;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPME($P(BGPG(X),U))=""
S X="",Y="",C=0 F S X=$O(BGPME(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPME(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPME=0,X=0 F S X=$O(BGPME(X)) Q:X'=+X S BGPME=BGPME+1
K BGPG S %=P_"^ALL PROCEDURE 99.45;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPME($P(BGPG(X),U))=""
S X="",Y="",C=0 F S X=$O(BGPME(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPME(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPME=0,X=0 F S X=$O(BGPME(X)) Q:X'=+X S BGPME=BGPME+1
MUPV ;
K BGPG S %=P_"^ALL DX V04.6;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPMU($P(BGPG(X),U))=""
S X="",Y="",C=0 F S X=$O(BGPMU(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPMU(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPMU=0,X=0 F S X=$O(BGPMU(X)) Q:X'=+X S BGPMU=BGPMU+1
K BGPG S %=P_"^ALL PROCEDURE 99.46;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPMU($P(BGPG(X),U))=""
S X="",Y="",C=0 F S X=$O(BGPMU(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPMU(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPMU=0,X=0 F S X=$O(BGPMU(X)) Q:X'=+X S BGPMU=BGPMU+1
RUBPV ;
K BGPG S %=P_"^ALL DX V04.3;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPRUB($P(BGPG(X),U))=""
S X="",Y="",C=0 F S X=$O(BGPRUB(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPRUB(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPRUB=0,X=0 F S X=$O(BGPRUB(X)) Q:X'=+X S BGPRUB=BGPRUB+1
K BGPG S %=P_"^ALL PROCEDURE 99.47;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPRUB($P(BGPG(X),U))=""
S X="",Y="",C=0 F S X=$O(BGPRUB(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPRUB(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPRUB=0,X=0 F S X=$O(BGPRUB(X)) Q:X'=+X S BGPRUB=BGPRUB+1
;
I BGPMR>1,BGPMU>1 Q 2_U_"m/r mu"
I BGPRM>1,BGPME>1 Q 2_U_"r/m me"
I BGPME>1,BGPMU>1,BGPRUB>1 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^BGP1D32(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^BGP1DU(P,"BGP MMR CONTRAINDICATIONS") Q 4_U_"contra MMR"
F BGPZ=3,94 S X=$$MMRCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra mmr"
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^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMR=3
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^BGP1D32(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^BGP1DU(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^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPME=3
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^BGP1DU(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^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMU=3
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^BGP1DU(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^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMU=3
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 ;;
BGP1D85 ; IHS/CMI/LAB - measure C 09 Jun 2011 5:18 PM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
I28 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20)=0
+2 SET (BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27)=0
+3 SET (BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6)=0
+4 SET BGPVALUE=""
+5 KILL BGPDTAP,BGPOPV,BGPMMR,BGPD,BGPT,BGPPER,BGPTET,BGPM,BGPMU,BGPME,BGPHIB,BGPHEP,BGPVAR
+6 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+7 ;must be active clinical
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+8 ;not 13 at beginning of time period
IF $$AGE^AUPNPAT(DFN,BGPBDATE)<13
SET BGPSTOP=1
QUIT
+9 IF $$AGE^AUPNPAT(DFN,BGPBDATE)>17
SET BGPSTOP=1
QUIT
+10 IF $$AGE^AUPNPAT(DFN,BGPBDATE)=13
SET BGPD1=1
IF BGPSEX="F"
SET BGPD3=1
+11 SET BGPD2=1
+12 IF BGPSEX="F"
SET BGPD4=1
+13 KILL ^TMP($JOB,"CPT")
+14 SET BGPVAL=$$TDAP^BGP1D86(DFN,BGPEDATE)
+15 ;any hit
IF $PIECE(BGPVAL,U,1)=1!($PIECE(BGPVAL,U,1)=4)!($PIECE(BGPVAL,U,1)=2)
SET BGPN10=1
+16 IF $PIECE(BGPVAL,U,1)=3
SET BGPN11=1
+17 ;evid disease, nmi, contraindication
IF $PIECE(BGPVAL,U,1)=4
SET BGPN12=1
+18 ;tdap
IF $PIECE(BGPVAL,U,2)["Tdap"
SET BGPN6=1
+19 IF $PIECE(BGPVAL,U,1)
SET BGPVALUE=$PIECE(BGPVAL,U,2)
+20 SET BGPVAL=$$MMR(DFN,BGPEDATE)
+21 ;any hit
IF $PIECE(BGPVAL,U,1)=1!($PIECE(BGPVAL,U,1)=4)!($PIECE(BGPVAL,U,1)=2)
SET BGPN7=1
+22 IF $PIECE(BGPVAL,U,1)=3
SET BGPN8=1
+23 ;evid disease, nmi, contraindication
IF $PIECE(BGPVAL,U,1)=4
SET BGPN9=1
+24 IF $PIECE(BGPVAL,U,1)
SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)
+25 SET BGPVAL=$$HEP^BGP1D35(DFN,BGPEDATE)
+26 ;any hit
IF $PIECE(BGPVAL,U,1)=1!($PIECE(BGPVAL,U,1)=4)!($PIECE(BGPVAL,U,1)=2)
SET BGPN13=1
+27 IF $PIECE(BGPVAL,U,1)=3
SET BGPN14=1
+28 ;evid disease, nmi, contraindication
IF $PIECE(BGPVAL,U,1)=4
SET BGPN15=1
+29 IF $PIECE(BGPVAL,U,1)
SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)
+30 SET BGPVAL=$$VAR^BGP1D35(DFN,BGPEDATE)
+31 ;any hit
IF $PIECE(BGPVAL,U,1)=1!($PIECE(BGPVAL,U,1)=4)!($PIECE(BGPVAL,U,1)=2)
SET BGPN16=1
+32 IF $PIECE(BGPVAL,U,1)=3
SET BGPN17=1
+33 ;evid disease, nmi, contraindication
IF $PIECE(BGPVAL,U,1)=4
SET BGPN18=1
+34 IF $PIECE(BGPVAL,U,1)
SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)
+35 SET BGPVAL=$$MEN^BGP1D36(DFN,BGPEDATE)
+36 ;any hit
IF $PIECE(BGPVAL,U,1)=1!($PIECE(BGPVAL,U,1)=4)!($PIECE(BGPVAL,U,1)=2)
SET BGPN1=1
+37 IF $PIECE(BGPVAL,U,1)=3
SET BGPN2=1
+38 ;evid disease, nmi, contraindication
IF $PIECE(BGPVAL,U,1)=4
SET BGPN3=1
+39 IF $PIECE(BGPVAL,U,1)
SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)
+40 SET BGPVAL=$$HPV^BGP1D36(DFN,BGPEDATE)
+41 ;any hit
IF $PIECE(BGPVAL,U,1)=1!($PIECE(BGPVAL,U,1)=4)!($PIECE(BGPVAL,U,1)=2)
SET BGPN4=1
+42 IF $PIECE(BGPVAL,U,1)=3
SET BGPN5=1
+43 ;evid disease, nmi, contraindication
IF $PIECE(BGPVAL,U,1)=4
SET BGPN27=1
+44 IF $PIECE(BGPVAL,U,1)
SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)
+45 ;15.1.1
IF BGPN7
IF BGPN13
IF BGPN16
SET BGPN19=1
+46 ;15.1.2
IF BGPN8!(BGPN17)!(BGPN14)
SET BGPN22=1
+47 ;15.1.3
IF BGPN9!(BGPN18)!(BGPN15)
SET BGPN23=1
+48 ;15.1.4
IF BGPN7
IF BGPN13
IF BGPN16
IF BGPN10
SET BGPN24=1
+49 ;15.1.5
IF BGPN8!(BGPN17)!(BGPN14)!(BGPN11)
SET BGPN25=1
+50 ;15.1.6
IF BGPN9!(BGPN18)!(BGPN15)!(BGPN12)
SET BGPN26=1
+51 IF BGPRTYPE=3
IF 'BGPN19
SET BGPVALUE="DID NOT HAVE: "
Begin DoDot:1
+52 IF 'BGPN7
SET BGPVALUE=BGPVALUE_"2 MMR;"
+53 IF 'BGPN13
SET BGPVALUE=BGPVALUE_"3 HEP;"
+54 IF 'BGPN16
SET BGPVALUE=BGPVALUE_"VAR"
End DoDot:1
+55 SET D=""
+56 SET D="AC"
+57 SET BGPVALUE=D_"|||"_BGPVALUE
+58 KILL BGPTET,BGPDTAP,BGPDT,BGPTD,BGPPER,BGPDIP,BGPMU,BGPME,BGPMMR,BGPMR,BGPRM,BGPOPV,BGPRUB,BGPHIB,BGPHEB,BGPVAR,BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6,BGPVAL
+59 QUIT
IMMREF(P,IMM,BD,ED) ;EP
+1 NEW X,Y,G,D,R
+2 IF 'IMM
QUIT ""
+3 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",IMM,0))
+4 IF 'Y
QUIT ""
+5 FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET R=$PIECE(^BIPC(X,0),U,3)
+7 IF R=""
QUIT
+8 IF '$DATA(^BICONT(R,0))
QUIT
+9 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+10 SET D=$PIECE(^BIPC(X,0),U,4)
+11 IF D=""
QUIT
+12 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+13 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+14 SET G=G+1
End DoDot:1
+15 QUIT G
MMR(P,EDATE) ;EP
+1 KILL BGPC,BGPG,BGPX,BGPMMR
+2 KILL ^TMP($JOB,"CPT")
+3 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+4 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+5 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+8 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-ED,Y)=""
End DoDot:3
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+10 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=+Y
IF $TEXT(@Y)]""
SET ^TMP($JOB,"CPT",9999999-ED,Y)=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET BGPMMR=0
+12 SET C="3^94"
+13 KILL BGPX
DO GETIMMS^BGP1D32(P,EDATE,C,.BGPMMR)
+14 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPMMR(X)=""
+15 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
+16 IF Y=90707!(Y=90710)
SET BGPMMR(D)=""
End DoDot:1
+17 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPMMR(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+18 IF C=1
SET Y=X
QUIT
+19 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPMMR(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 ;now count them and see if there are 4 of them
+22 SET BGPMMR=0
SET X=0
FOR
SET X=$ORDER(BGPMMR(X))
IF X'=+X
QUIT
SET BGPMMR=BGPMMR+1
+23 IF BGPMMR>1
QUIT 1_U_"2 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^BGP1D32(P,EDATE,C,.BGPX)
+4 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPMR(X)=""
+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(D)=""
End DoDot:1
+7 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+8 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPMR(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+9 IF C=1
SET Y=X
QUIT
+10 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPMR(X)
QUIT
+11 SET Y=X
End DoDot:1
+12 ;count them
+13 SET X=0
FOR
SET X=$ORDER(BGPMR(X))
IF X'=+X
QUIT
SET BGPMR=BGPMR+1
RM ;
+1 SET C=38
+2 KILL BGPX
DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+3 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPRM(X)=""
+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(D)=""
End DoDot:1
+6 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+7 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPRM(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+8 IF C=1
SET Y=X
QUIT
+9 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPRM(X)
QUIT
+10 SET Y=X
End DoDot:1
+11 ;count them
+12 SET X=0
FOR
SET X=$ORDER(BGPRM(X))
IF X'=+X
QUIT
SET BGPRM=BGPRM+1
ME SET C=5
+1 KILL BGPX
DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+2 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPME(X)=""
+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(D)=""
End DoDot:1
+5 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+6 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPME(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+7 IF C=1
SET Y=X
QUIT
+8 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPME(X)
QUIT
+9 SET Y=X
End DoDot:1
+10 ;count them
+11 SET X=0
FOR
SET X=$ORDER(BGPME(X))
IF X'=+X
QUIT
SET BGPME=BGPME+1
MU SET C=7
+1 KILL BGPX
DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+2 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPMU(X)=""
+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(D)=""
End DoDot:1
+5 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+6 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPMU(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+7 IF C=1
SET Y=X
QUIT
+8 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPMU(X)
QUIT
+9 SET Y=X
End DoDot:1
+10 ;count them
+11 SET X=0
FOR
SET X=$ORDER(BGPMU(X))
IF X'=+X
QUIT
SET BGPMU=BGPMU+1
RUB SET C=6
+1 KILL BGPX
DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+2 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPRUB(X)=""
+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(D)=""
End DoDot:1
+5 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+6 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPRUB(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+7 IF C=1
SET Y=X
QUIT
+8 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPRUB(X)
QUIT
+9 SET Y=X
End DoDot:1
+10 ;count them
+11 SET X=0
FOR
SET X=$ORDER(BGPRUB(X))
IF X'=+X
QUIT
SET BGPRUB=BGPRUB+1
+12 IF BGPMR>1
IF BGPMU>1
QUIT 1_U_"2 m/r 2 mu"
+13 IF BGPRM>1
IF BGPME>1
QUIT 1_U_"2 r/m 2 me"
+14 IF BGPME>1
IF BGPMU>1
IF BGPRUB>1
QUIT 1_U_"2 me 2 mu 2 rub"
+15 ;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 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPMMR($PIECE(BGPG(X),U))=""
+3 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPMMR(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+4 IF C=1
SET Y=X
QUIT
+5 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPMMR(X)
QUIT
+6 SET Y=X
End DoDot:1
+7 ;now count them and see if there are 4 of them
+8 SET BGPMMR=0
SET X=0
FOR
SET X=$ORDER(BGPMMR(X))
IF X'=+X
QUIT
SET BGPMMR=BGPMMR+1
+9 IF BGPMMR>1
QUIT 2_U_"2 MMR (DX/IMM)"
+10 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.48;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+11 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPMMR($PIECE(BGPG(X),U))=""
+12 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPMMR(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+13 IF C=1
SET Y=X
QUIT
+14 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPMMR(X)
QUIT
+15 SET Y=X
End DoDot:1
+16 ;now count them and see if there are 4 of them
+17 SET BGPMMR=0
SET X=0
FOR
SET X=$ORDER(BGPMMR(X))
IF X'=+X
QUIT
SET BGPMMR=BGPMMR+1
+18 IF BGPMMR>1
QUIT 2_U_"2 MMR (PROC/IMM)"
MEPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V04.2;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPME($PIECE(BGPG(X),U))=""
+3 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPME(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+4 IF C=1
SET Y=X
QUIT
+5 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPME(X)
QUIT
+6 SET Y=X
End DoDot:1
+7 ;now count them and see if there are 4 of them
+8 SET BGPME=0
SET X=0
FOR
SET X=$ORDER(BGPME(X))
IF X'=+X
QUIT
SET BGPME=BGPME+1
+9 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.45;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+10 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPME($PIECE(BGPG(X),U))=""
+11 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPME(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+12 IF C=1
SET Y=X
QUIT
+13 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPME(X)
QUIT
+14 SET Y=X
End DoDot:1
+15 ;now count them and see if there are 4 of them
+16 SET BGPME=0
SET X=0
FOR
SET X=$ORDER(BGPME(X))
IF X'=+X
QUIT
SET BGPME=BGPME+1
MUPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V04.6;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPMU($PIECE(BGPG(X),U))=""
+3 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPMU(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+4 IF C=1
SET Y=X
QUIT
+5 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPMU(X)
QUIT
+6 SET Y=X
End DoDot:1
+7 ;now count them and see if there are 4 of them
+8 SET BGPMU=0
SET X=0
FOR
SET X=$ORDER(BGPMU(X))
IF X'=+X
QUIT
SET BGPMU=BGPMU+1
+9 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.46;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+10 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPMU($PIECE(BGPG(X),U))=""
+11 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPMU(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+12 IF C=1
SET Y=X
QUIT
+13 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPMU(X)
QUIT
+14 SET Y=X
End DoDot:1
+15 ;now count them and see if there are 4 of them
+16 SET BGPMU=0
SET X=0
FOR
SET X=$ORDER(BGPMU(X))
IF X'=+X
QUIT
SET BGPMU=BGPMU+1
RUBPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V04.3;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPRUB($PIECE(BGPG(X),U))=""
+3 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPRUB(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+4 IF C=1
SET Y=X
QUIT
+5 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPRUB(X)
QUIT
+6 SET Y=X
End DoDot:1
+7 ;now count them and see if there are 4 of them
+8 SET BGPRUB=0
SET X=0
FOR
SET X=$ORDER(BGPRUB(X))
IF X'=+X
QUIT
SET BGPRUB=BGPRUB+1
+9 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.47;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+10 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPRUB($PIECE(BGPG(X),U))=""
+11 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPRUB(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+12 IF C=1
SET Y=X
QUIT
+13 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPRUB(X)
QUIT
+14 SET Y=X
End DoDot:1
+15 ;now count them and see if there are 4 of them
+16 SET BGPRUB=0
SET X=0
FOR
SET X=$ORDER(BGPRUB(X))
IF X'=+X
QUIT
SET BGPRUB=BGPRUB+1
+17 ;
+18 IF BGPMR>1
IF BGPMU>1
QUIT 2_U_"m/r mu"
+19 IF BGPRM>1
IF BGPME>1
QUIT 2_U_"r/m me"
+20 IF BGPME>1
IF BGPMU>1
IF BGPRUB>1
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^BGP1D32(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^BGP1DU(P,"BGP MMR CONTRAINDICATIONS")
QUIT 4_U_"contra MMR"
+3 FOR BGPZ=3,94
SET X=$$MMRCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+4 IF X]""
QUIT 4_U_"contra mmr"
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^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPMR=3
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^BGP1D32(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^BGP1DU(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^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPME=3
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^BGP1DU(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^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPMU=3
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^BGP1DU(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^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)
SET BGPMU=3
+9 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:"")
+10 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:"")
+11 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:"")
+12 QUIT ""
90707 ;;
90710 ;;
90708 ;;
90709 ;;
90705 ;;
90704 ;;
90706 ;;
