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

BGP1D85.m

Go to the documentation of this file. 
  1. BGP1D85 ; IHS/CMI/LAB - measure C 09 Jun 2011 5:18 PM ;
  1.  ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
  1.  ;
  1. I28 ;EP
  1.  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
  1.  S (BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27)=0
  1.  S (BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6)=0
  1.  S BGPVALUE=""
  1.  K BGPDTAP,BGPOPV,BGPMMR,BGPD,BGPT,BGPPER,BGPTET,BGPM,BGPMU,BGPME,BGPHIB,BGPHEP,BGPVAR
  1.  I 'BGPACTUP S BGPSTOP=1 Q
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;must be active clinical
  1.  I $$AGE^AUPNPAT(DFN,BGPBDATE)<13 S BGPSTOP=1 Q  ;not 13 at beginning of time period
  1.  I $$AGE^AUPNPAT(DFN,BGPBDATE)>17 S BGPSTOP=1 Q
  1.  I $$AGE^AUPNPAT(DFN,BGPBDATE)=13 S BGPD1=1 I BGPSEX="F" S BGPD3=1
  1.  S BGPD2=1
  1.  I BGPSEX="F" S BGPD4=1
  1.  K ^TMP($J,"CPT")
  1.  S BGPVAL=$$TDAP^BGP1D86(DFN,BGPEDATE)
  1.  I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN10=1  ;any hit
  1.  I $P(BGPVAL,U,1)=3 S BGPN11=1
  1.  I $P(BGPVAL,U,1)=4 S BGPN12=1 ;evid disease, nmi, contraindication
  1.  I $P(BGPVAL,U,2)["Tdap" S BGPN6=1  ;tdap
  1.  I $P(BGPVAL,U,1) S BGPVALUE=$P(BGPVAL,U,2)
  1.  S BGPVAL=$$MMR(DFN,BGPEDATE)
  1.  I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN7=1  ;any hit
  1.  I $P(BGPVAL,U,1)=3 S BGPN8=1
  1.  I $P(BGPVAL,U,1)=4 S BGPN9=1 ;evid disease, nmi, contraindication
  1.  I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)
  1.  S BGPVAL=$$HEP^BGP1D35(DFN,BGPEDATE)
  1.  I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN13=1  ;any hit
  1.  I $P(BGPVAL,U,1)=3 S BGPN14=1
  1.  I $P(BGPVAL,U,1)=4 S BGPN15=1 ;evid disease, nmi, contraindication
  1.  I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)
  1.  S BGPVAL=$$VAR^BGP1D35(DFN,BGPEDATE)
  1.  I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN16=1  ;any hit
  1.  I $P(BGPVAL,U,1)=3 S BGPN17=1
  1.  I $P(BGPVAL,U,1)=4 S BGPN18=1 ;evid disease, nmi, contraindication
  1.  I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)
  1.  S BGPVAL=$$MEN^BGP1D36(DFN,BGPEDATE)
  1.  I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN1=1  ;any hit
  1.  I $P(BGPVAL,U,1)=3 S BGPN2=1
  1.  I $P(BGPVAL,U,1)=4 S BGPN3=1 ;evid disease, nmi, contraindication
  1.  I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)
  1.  S BGPVAL=$$HPV^BGP1D36(DFN,BGPEDATE)
  1.  I $P(BGPVAL,U,1)=1!($P(BGPVAL,U,1)=4)!($P(BGPVAL,U,1)=2) S BGPN4=1  ;any hit
  1.  I $P(BGPVAL,U,1)=3 S BGPN5=1
  1.  I $P(BGPVAL,U,1)=4 S BGPN27=1 ;evid disease, nmi, contraindication
  1.  I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)
  1.  I BGPN7,BGPN13,BGPN16 S BGPN19=1  ;15.1.1
  1.  I BGPN8!(BGPN17)!(BGPN14) S BGPN22=1  ;15.1.2
  1.  I BGPN9!(BGPN18)!(BGPN15) S BGPN23=1  ;15.1.3
  1.  I BGPN7,BGPN13,BGPN16,BGPN10 S BGPN24=1  ;15.1.4
  1.  I BGPN8!(BGPN17)!(BGPN14)!(BGPN11) S BGPN25=1  ;15.1.5
  1.  I BGPN9!(BGPN18)!(BGPN15)!(BGPN12) S BGPN26=1  ;15.1.6
  1.  I BGPRTYPE=3,'BGPN19 S BGPVALUE="DID NOT HAVE: " D
  1.  .I 'BGPN7 S BGPVALUE=BGPVALUE_"2 MMR;"
  1.  .I 'BGPN13 S BGPVALUE=BGPVALUE_"3 HEP;"
  1.  .I 'BGPN16 S BGPVALUE=BGPVALUE_"VAR"
  1.  S D=""
  1.  S D="AC"
  1.  S BGPVALUE=D_"|||"_BGPVALUE
  1.  K BGPTET,BGPDTAP,BGPDT,BGPTD,BGPPER,BGPDIP,BGPMU,BGPME,BGPMMR,BGPMR,BGPRM,BGPOPV,BGPRUB,BGPHIB,BGPHEB,BGPVAR,BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6,BGPVAL
  1.  Q
  1. IMMREF(P,IMM,BD,ED) ;EP
  1.  NEW X,Y,G,D,R
  1.  I 'IMM Q ""
  1.  S (X,G)=0,Y=$O(^AUTTIMM("C",IMM,0))
  1.  I 'Y Q ""
  1.  F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X  D
  1.  .S R=$P(^BIPC(X,0),U,3)
  1.  .Q:R=""
  1.  .Q:'$D(^BICONT(R,0))
  1.  .Q:$P(^BICONT(R,0),U,1)'["Refusal"
  1.  .S D=$P(^BIPC(X,0),U,4)
  1.  .Q:D=""
  1.  .Q:$P(^BIPC(X,0),U,4)<BD
  1.  .Q:$P(^BIPC(X,0),U,4)>ED
  1.  .S G=G+1
  1.  Q G
  1. MMR(P,EDATE) ;EP
  1.  K BGPC,BGPG,BGPX,BGPMMR
  1.  K ^TMP($J,"CPT")
  1.  S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X  D
  1.  ...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)=""
  1.  ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D
  1.  ...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)=""
  1.  S BGPMMR=0
  1.  S C="3^94"
  1.  K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPMMR)
  1.  S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPMMR(X)=""
  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
  1.  .I Y=90707!(Y=90710) S BGPMMR(D)=""
  1.  S X="",Y="",C=0 F  S X=$O(BGPMMR(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPMMR(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPMMR=0,X=0 F  S X=$O(BGPMMR(X)) Q:X'=+X  S BGPMMR=BGPMMR+1
  1.  I BGPMMR>1 Q 1_U_"2 MMR"
  1. MR ;see if one M/R, Mumps or R/M
  1.  S (BGPMR,BGPRM,BGPME,BGPMU,BGPRUB)=0
  1.  S C=4
  1.  K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
  1.  S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPMR(X)=""
  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
  1.  .I Y=90708 S BGPMR(D)=""
  1.   ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPMR(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPMR(X) Q
  1.  .S Y=X
  1.  ;count them
  1.  S X=0 F  S X=$O(BGPMR(X)) Q:X'=+X  S BGPMR=BGPMR+1
  1. RM ;
  1.  S C=38
  1.  K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
  1.  S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPRM(X)=""
  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
  1.  .I Y=90709 S BGPRM(D)=""
  1.   ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPRM(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPRM(X) Q
  1.  .S Y=X
  1.  ;count them
  1.  S X=0 F  S X=$O(BGPRM(X)) Q:X'=+X  S BGPRM=BGPRM+1
  1. ME S C=5
  1.  K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
  1.  S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPME(X)=""
  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
  1.  .I Y=90705 S BGPME(D)=""
  1.  ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPME(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPME(X) Q
  1.  .S Y=X
  1.  ;count them
  1.  S X=0 F  S X=$O(BGPME(X)) Q:X'=+X  S BGPME=BGPME+1
  1. MU S C=7
  1.  K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
  1.  S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPMU(X)=""
  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
  1.  .I Y=90704 S BGPMU(D)=""
  1.   ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPMU(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPMU(X) Q
  1.  .S Y=X
  1.  ;count them
  1.  S X=0 F  S X=$O(BGPMU(X)) Q:X'=+X  S BGPMU=BGPMU+1
  1. RUB S C=6
  1.  K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
  1.  S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPRUB(X)=""
  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
  1.  .I Y=90706 S BGPRUB(D)=""
  1.  ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPRUB(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPRUB(X) Q
  1.  .S Y=X
  1.  ;count them
  1.  S X=0 F  S X=$O(BGPRUB(X)) Q:X'=+X  S BGPRUB=BGPRUB+1
  1.  I BGPMR>1,BGPMU>1 Q 1_U_"2 m/r 2 mu"
  1.  I BGPRM>1,BGPME>1 Q 1_U_"2 r/m 2 me"
  1.  I BGPME>1,BGPMU>1,BGPRUB>1 Q 1_U_"2 me 2 mu 2 rub"
  1.  ;now add diagnoses and proc codes for code 2
  1. PVS ;
  1.  K BGPG S %=P_"^ALL DX V06.4;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPMMR($P(BGPG(X),U))=""
  1.  S X="",Y="",C=0 F  S X=$O(BGPMMR(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPMMR(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPMMR=0,X=0 F  S X=$O(BGPMMR(X)) Q:X'=+X  S BGPMMR=BGPMMR+1
  1.  I BGPMMR>1 Q 2_U_"2 MMR (DX/IMM)"
  1.  K BGPG S %=P_"^ALL PROCEDURE 99.48;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPMMR($P(BGPG(X),U))=""
  1.  S X="",Y="",C=0 F  S X=$O(BGPMMR(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPMMR(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPMMR=0,X=0 F  S X=$O(BGPMMR(X)) Q:X'=+X  S BGPMMR=BGPMMR+1
  1.  I BGPMMR>1 Q 2_U_"2 MMR (PROC/IMM)"
  1. MEPV ;
  1.  K BGPG S %=P_"^ALL DX V04.2;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPME($P(BGPG(X),U))=""
  1.  S X="",Y="",C=0 F  S X=$O(BGPME(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPME(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPME=0,X=0 F  S X=$O(BGPME(X)) Q:X'=+X  S BGPME=BGPME+1
  1.  K BGPG S %=P_"^ALL PROCEDURE 99.45;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPME($P(BGPG(X),U))=""
  1.  S X="",Y="",C=0 F  S X=$O(BGPME(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPME(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPME=0,X=0 F  S X=$O(BGPME(X)) Q:X'=+X  S BGPME=BGPME+1
  1. MUPV ;
  1.  K BGPG S %=P_"^ALL DX V04.6;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPMU($P(BGPG(X),U))=""
  1.  S X="",Y="",C=0 F  S X=$O(BGPMU(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPMU(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPMU=0,X=0 F  S X=$O(BGPMU(X)) Q:X'=+X  S BGPMU=BGPMU+1
  1.  K BGPG S %=P_"^ALL PROCEDURE 99.46;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPMU($P(BGPG(X),U))=""
  1.  S X="",Y="",C=0 F  S X=$O(BGPMU(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPMU(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPMU=0,X=0 F  S X=$O(BGPMU(X)) Q:X'=+X  S BGPMU=BGPMU+1
  1. RUBPV ;
  1.  K BGPG S %=P_"^ALL DX V04.3;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPRUB($P(BGPG(X),U))=""
  1.  S X="",Y="",C=0 F  S X=$O(BGPRUB(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPRUB(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPRUB=0,X=0 F  S X=$O(BGPRUB(X)) Q:X'=+X  S BGPRUB=BGPRUB+1
  1.  K BGPG S %=P_"^ALL PROCEDURE 99.47;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPRUB($P(BGPG(X),U))=""
  1.  S X="",Y="",C=0 F  S X=$O(BGPRUB(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPRUB(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPRUB=0,X=0 F  S X=$O(BGPRUB(X)) Q:X'=+X  S BGPRUB=BGPRUB+1
  1.  ;
  1.  I BGPMR>1,BGPMU>1 Q 2_U_"m/r mu"
  1.  I BGPRM>1,BGPME>1 Q 2_U_"r/m me"
  1.  I BGPME>1,BGPMU>1,BGPRUB>1 Q 2_U_"me mu rub"
  1. REF ;
  1.  ;now get a refusal of MMR if there is one
  1.  S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",BGPMMR=0,R=""
  1.  F BGPIMM=3,94 D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .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
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI MMR",1:"ref MMR")
  1.  ;now check refusals in imm pkg
  1.  S R="" F BGPIMM=3,94 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1.  I R Q 3_U_"ref mmr"
  1. MMRC K BGPG S %=P_"^LAST DX [BGP MMR CONTRAINDICATIONS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q 4_U_"contra mmr"
  1.  I $$PLTAX^BGP1DU(P,"BGP MMR CONTRAINDICATIONS") Q 4_U_"contra MMR"
  1.  F BGPZ=3,94 S X=$$MMRCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
  1.  I X]"" Q 4_U_"contra mmr"
  1. REFMR ;
  1.  I BGPMR=0 D
  1.  .S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI=""
  1.  .F BGPIMM=4 D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .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)
  1.  ;now check refusals in imm pkg
  1.  F BGPIMM=4 I $$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMR=3
  1. REFRM I BGPRM=0 D
  1.  .S B=$$DOB^AUPNPAT(P),E=EDATE
  1.  .F BGPIMM=38 D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .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)
  1.  F BGPIMM=38 I $$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPRM=3
  1. MEX ;
  1.  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
  1.  I $$PLTAX^BGP1DU(P,"BGP MEASLES EVIDENCE") S BGPME=1
  1.  I BGPME=0 D
  1.  .S B=$$DOB^AUPNPAT(P),E=EDATE
  1.  .F BGPIMM=5 D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .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)
  1.  F BGPIMM=7 I $$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPME=3
  1. MUX ;
  1.  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
  1.  I $$PLTAX^BGP1DU(P,"BGP MUMPS EVIDENCE") S BGPMU=1
  1.  I BGPMU=0 D
  1.  .S B=$$DOB^AUPNPAT(P),E=EDATE
  1.  .F BGPIMM=7 D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .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)
  1.  ;now check refusals in imm pkg
  1.  F BGPIMM="7" I $$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMU=3
  1. RUBX ;
  1.  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
  1.  I $$PLTAX^BGP1DU(P,"BGP RUBELLA EVIDENCE") S BGPRUB=1
  1.  I BGPRUB=0 D
  1.  .S B=$$DOB^AUPNPAT(P),E=EDATE
  1.  .F BGPIMM=6 D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .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)
  1.  F BGPIMM=6 I $$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMU=3
  1.  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:"")
  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:"")
  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:"")
  1.  Q ""
  1. 90707 ;;
  1. 90710 ;;
  1. 90708 ;;
  1. 90709 ;;
  1. 90705 ;;
  1. 90704 ;;
  1. 90706 ;;