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

BGP2D33.m

Go to the documentation of this file.
  1. BGP2D33 ; IHS/CMI/LAB - measure C ;
  1. ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  1. ;
  1. OPV(P,EDATE) ;EP
  1. K BGPC,BGPG,BGPX
  1. ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
  1. K BGPOPV,BGPAPOV
  1. ;get all immunizations
  1. S C="2^89^10^110^120^130^132^146"
  1. K BGPX D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
  1. ;go through and set into array if 10 days apart
  1. S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPOPV(X)="",BGPAPOV(X)=""
  1. ;now get cpts
  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=90712!(Y=90698)!(Y=90711)!(Y=90713)!(Y=90723)!(Y=90696) S BGPOPV(9999999-$P(ED,"."))="",BGPAPOV(9999999-$P(ED,"."))=""
  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=90712!(Y=90698)!(Y=90711)!(Y=90713)!(Y=90723)!(Y=90696) S BGPOPV(9999999-$P(ED,"."))="",BGPAPOV(9999999-$P(ED,"."))=""
  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(BGPOPV(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 BGPOPV(X) Q
  1. .S Y=X
  1. ;now count them and see if there are 4 of them
  1. S BGPOPV=0,X=0 F S X=$O(BGPOPV(X)) Q:X'=+X S BGPOPV=BGPOPV+1
  1. I BGPOPV>2 Q 1_U_"3 Polio"
  1. ;now get povs
  1. K BGPPOV M BGPPOV=BGPAPOV
  1. K BGPG S %=P_"^ALL DX [BGP IPV IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. 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))=""
  1. K BGPG D SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP IPV IZ PROCS",.BGPG)
  1. 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))=""
  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(BGPOPV(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 BGPOPV(X) Q
  1. .S Y=X
  1. ;now count them and see if there are 4 of them
  1. S BGPOPV=0,X=0 F S X=$O(BGPOPV(X)) Q:X'=+X S BGPOPV=BGPOPV+1
  1. I BGPOPV>2 Q 2_U_"3 Polio"
  1. ;check for Evidence of desease and Contraindications and if yes, then quit
  1. K BGPG S %=P_"^LAST DX [BGP OPV EVID DISEASE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) Q 4_U_"Evid Polio"
  1. I $$PLTAX^BGP2DU(P,"BGP OPV EVID DISEASE") Q 4_U_"Evid Polio"
  1. K BGPG S %=P_"^LAST DX [BGP OPV CONTRAINDICATIONS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) Q 4_U_"Contra Polio"
  1. I $$PLTAX^BGP2DU(P,"BGP OPV CONTRAINDICATONS") Q 4_U_"Contra Polio"
  1. F BGPZ=2,89 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra Polio"
  1. F BGPZ=10,89,110,120,130,132,146 S X=$$ANNECONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra Polio"
  1. ;now go to Refusals
  1. S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
  1. F BGPIMM=2,89,10,110,120,130,132,146 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 Polio",1:"Ref Polio")
  1. F BGPIMM=90712,90696,90698,90711,90713,90723 D
  1. .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1. .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
  1. I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Polio",1:"Ref Polio")
  1. ;now check Refusals in imm pkg
  1. F BGPIMM=2,89,10,110,120,130,132,146 S R=$$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1. I R Q 3_U_"Ref Polio"
  1. Q ""
  1. MMR(P,EDATE) ;EP
  1. K BGPC,BGPG,BGPX
  1. K ^TMP($J,"CPT")
  1. ;first gather up all cpt codes that relate in any way to dtap and store in ^TMP
  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. ..Q:'$D(^AUPNVCPT("AD",V))
  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-$P(ED,"."),Y)=""
  1. S BGPMMR=0
  1. ;get all immunizations
  1. S C="3^94"
  1. K BGPX D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
  1. I $D(BGPX) Q 1_U_"MMR"
  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=1
  1. I BGPMMR Q 1_U_"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^BGP2D32(P,EDATE,C,.BGPX)
  1. I $D(BGPX) S BGPMR=1
  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=1
  1. RM ;
  1. S C=38
  1. D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
  1. I $D(BGPX) S BGPRM=1
  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=1
  1. ME S C=5
  1. K BGPX D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
  1. I $D(BGPX) S BGPME=1
  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=1
  1. MU S C=7
  1. D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
  1. I $D(BGPX) S BGPMU=1
  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=1
  1. RUB S C=6
  1. D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
  1. I $D(BGPX) S BGPRUB=1
  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=1
  1. I BGPMR,BGPMU Q 1_U_"m/r mu"
  1. I BGPRM,BGPME Q 1_U_"r/m me"
  1. I BGPME,BGPMU,BGPRUB Q 1_U_"me mu rub"
  1. ;now add diagnoses and proc codes for code 2
  1. PVS ;
  1. K BGPG S %=P_"^ALL DX [BGP MMR IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) Q 2_U_"MMR"
  1. K BGPG S BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP MMR IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
  1. I BGPG(1)]"" Q 2_U_"MMR"
  1. MEPV ;
  1. K BGPG S %=P_"^ALL DX [BGP MEASLES IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) S BGPME=1
  1. K BGPG S BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP MEASLES IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
  1. I BGPG(1)]"" S BGPME=1
  1. MUPV ;
  1. K BGPG S %=P_"^ALL DX [BGP MUMPS IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) S BGPMU=1
  1. K BGPG S BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP MUMPS IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
  1. I BGPG(1)]"" S BGPMU=1
  1. RUBPV ;
  1. K BGPG S %=P_"^ALL DX [BGP RUBELLA IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) S BGPRUB=1
  1. K BGPG S BGPG(1)=$$LASTPRC^BGP2UTL1(P,"BGP RUBELLA IZ PROCS",$$DOB^AUPNPAT(P),EDATE)
  1. I BGPG(1)]"" S BGPRUB=1
  1. I BGPMR,BGPMU Q 2_U_"m/r mu"
  1. I BGPRM,BGPME Q 2_U_"r/m me"
  1. I BGPME,BGPMU,BGPRUB 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. F BGPIMM=90707,90710 D
  1. .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1. .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
  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^BGP2D32(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^BGP2DU(P,"BGP MMR CONTRAINDICATIONS") Q 4_U_"Contra MMR"
  1. F BGPZ=3,94 S X=$$MMRCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra MMR"
  1. MRC ;
  1. F BGPZ=4 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra MR"
  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. .F BGPIMM=90708 D
  1. ..S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1. ..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)
  1. ;now check Refusals in imm pkg
  1. F BGPIMM=4 I $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMR=3
  1. RMC ;
  1. F BGPZ=38 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra RM"
  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=90709 D
  1. ..S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1. ..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)
  1. F BGPIMM=38 I $$IMMREF^BGP2D32(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^BGP2DU(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=90705 D
  1. ..S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1. ..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)
  1. F BGPIMM=7 I $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPME=3
  1. F BGPZ=5 S X=$$MMRCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" S BGPME=4
  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^BGP2DU(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. .F BGPIMM=90704 D
  1. ..S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1. ..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)
  1. ;now check Refusals in imm pkg
  1. F BGPIMM="7" I $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPMU=3
  1. F BGPZ=7 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" S BGPMU=4
  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^BGP2DU(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=90706 D
  1. ..S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1. ..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)
  1. F BGPIMM=6 I $$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE) S BGPRUB=3
  1. F BGPZ=6 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" S BGPRUB=4
  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_$S(X=4:" NMI",X=3:" Ref",1:"")_" MR & MU"
  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_$S(X=4:" NMI",X=3:" Ref",1:"")_" RM & ME"
  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_$S(X=4:" NMI",X=3:" Ref",1:"")_" 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 ;;