BGP2D811 ; IHS/CMI/LAB - PCR, MMR
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
PCR(P,BDATE,EDATE) ;EP
NEW BGPG,%,E,A,T,X,G,J,I
S %=P_"^LAST LAB [BGP HIV VIRAL LOAD TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U,1)_U_$P(BGPG(1),U,2)
S E=+$$CODEN^ICPTCOD(87536),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^87536"
S E=+$$CODEN^ICPTCOD(87539),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^87539"
S E=+$$CODEN^ICPTCOD(87536),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^87536 TRAN"
S E=+$$CODEN^ICPTCOD(87539),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^87539 TRAN"
;now go through all labs and check loinc codes
K ^TMP($J,"A")
S A="^TMP($J,""A"",",%=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
I '$D(^TMP($J,"A",1)) Q ""
;now go through all lab tests and see if any are the loinc codes in the taxonomy
S T=$O(^ATXAX("B","BGP VIRAL LOAD LOINC CODES",0))
I 'T Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S I=+$P(^TMP($J,"A",X),U,4) I $P($G(^AUPNVLAB(I,11)),U,13)]"" D
.S J=$P(^AUPNVLAB(I,11),U,13)
.I $$LOINC^BGP2D21(J,T) S G=1_U_$$VD^APCLV($P(^AUPNVLAB(I,0),U,3))_U_$$VAL^XBDIQ1(9000010.09,I,.01)
Q G
MMR(P,EDATE) ;EP
NEW BGPC,BGPG,BGPX,BGPMMR,ED,BD,V,X,Y,C,D,BGPME,BGPMU,BGPRUB,BGPMR,BGPRM,BGPNMI,BGPIMM
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^BGP2D32(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^BGP2D32(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^BGP2D32(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^BGP2D32(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^BGP2D32(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^BGP2D32(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 [BGP MMR IZ DXS;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 D SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP MMR IZ PROCS",.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 [BGP MEASLES IZ DXS;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 D SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP MEASLES IZ PROCS",.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 [BGP MUMPS IZ DXS;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 D SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP MUMPS IZ PROCS",.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 [BGP RUBELLA IZ DXS;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 D SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP RUBELLA IZ PROCS",.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")
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"
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
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
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
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
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 ;;
BGP2D811 ; IHS/CMI/LAB - PCR, MMR
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
PCR(P,BDATE,EDATE) ;EP
+1 NEW BGPG,%,E,A,T,X,G,J,I
+2 SET %=P_"^LAST LAB [BGP HIV VIRAL LOAD TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U,1)_U_$PIECE(BGPG(1),U,2)
+4 SET E=+$$CODEN^ICPTCOD(87536)
SET %=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^87536"
+5 SET E=+$$CODEN^ICPTCOD(87539)
SET %=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^87539"
+6 SET E=+$$CODEN^ICPTCOD(87536)
SET %=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^87536 TRAN"
+7 SET E=+$$CODEN^ICPTCOD(87539)
SET %=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^87539 TRAN"
+8 ;now go through all labs and check loinc codes
+9 KILL ^TMP($JOB,"A")
+10 SET A="^TMP($J,""A"","
SET %=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+11 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+12 ;now go through all lab tests and see if any are the loinc codes in the taxonomy
+13 SET T=$ORDER(^ATXAX("B","BGP VIRAL LOAD LOINC CODES",0))
+14 IF 'T
QUIT ""
+15 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET I=+$PIECE(^TMP($JOB,"A",X),U,4)
IF $PIECE($GET(^AUPNVLAB(I,11)),U,13)]""
Begin DoDot:1
+16 SET J=$PIECE(^AUPNVLAB(I,11),U,13)
+17 IF $$LOINC^BGP2D21(J,T)
SET G=1_U_$$VD^APCLV($PIECE(^AUPNVLAB(I,0),U,3))_U_$$VAL^XBDIQ1(9000010.09,I,.01)
End DoDot:1
+18 QUIT G
MMR(P,EDATE) ;EP
+1 NEW BGPC,BGPG,BGPX,BGPMMR,ED,BD,V,X,Y,C,D,BGPME,BGPMU,BGPRUB,BGPMR,BGPRM,BGPNMI,BGPIMM
+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^BGP2D32(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^BGP2D32(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^BGP2D32(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^BGP2D32(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^BGP2D32(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^BGP2D32(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 [BGP MMR IZ DXS;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
DO SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP MMR IZ PROCS",.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 [BGP MEASLES IZ DXS;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
DO SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP MEASLES IZ PROCS",.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 [BGP MUMPS IZ DXS;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
DO SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP MUMPS IZ PROCS",.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 [BGP RUBELLA IZ DXS;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
DO SETPRC^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP RUBELLA IZ PROCS",.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 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"
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
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
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
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 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:"")
+13 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:"")
+14 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:"")
+15 QUIT ""
90707 ;;
90710 ;;
90708 ;;
90709 ;;
90705 ;;
90704 ;;
90706 ;;
