BGP8D35 ;IHS/CMI/LAB - MEASURE LOGIC;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
VAR(P,EDATE) ;EP
NEW BGPC,BGPG,BGPX,BGPVARI,C,ED,BD,G,V,X,Y,BGPZ,B,BGPIMM,R,BGPNMI
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPVARI
;get all immunizations
S C="21^94"
D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
;go through and set into array if 10 days apart
I $O(BGPX(0)) Q 1_U_"Vari"
;now get cpts
S ED=9999999-EDATE-1,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=90710!(Y=90716) S BGPVARI(9999999-$P(ED,"."))=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90710!(Y=90716) S BGPVARI(9999999-$P(ED,"."))=""
I $D(BGPVARI) Q 1_U_"Vari"
K BGPG S %=P_"^ALL DX [BGP VARICELLA IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 2_U_"Vari"
;check for Evidence of desease and Contraindications and if yes, then quit
K BGPG S %=P_"^LAST DX [BGP VARICELLA EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 4_U_"Evid Vari"
I $$PLTAXND^BGP8DU(P,"BGP VARICELLA EVIDENCE",EDATE) Q 4_U_"Evid Vari"
I $$IPLSNOND^BGP8DU(P,"PXRM BGP VARICELLA",EDATE) Q 4_U_"Evid Vari"
F BGPZ=21,94 S X=$$EVIDVAR(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Evid Vari"
S BGPZ=$$IMMUNO^BGP8D36(P,EDATE) I BGPZ Q 4_U_"Contra Vari"
S BGPZ=$$HIVDX^BGP8D24A(P,$$DOB^AUPNPAT(P),EDATE) I BGPZ Q 4_U_"Contra Vari"
S BGPZ=$$LYMPHO^BGP8D36(P,EDATE) I BGPZ Q 4_U_"Contra Vari"
F BGPZ=21,94 S X=$$MMRCONT^BGP8D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra Vari"
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=21,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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Vari",1:"Ref Vari")
F BGPIMM=90710,90716 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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Vari",1:"Ref Vari")
;now check Refusals in imm pkg
;F BGPIMM=21,94 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q 3_U_"Ref imm pkg Vari"
Q ""
HEP(P,EDATE) ;EP
NEW BGPC,BGPG,BGPX,BGPHEP,X,ED,BD,G,T,BGP10743,V,Z,Y,C
S BGP10743=""
;get all immunizations
S C="8^42^43^44^45^51^102^104^110^132^146^189"
D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
;go through and set into array if 10 days apart
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPHEP(X)=""
;now get cpts
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
S T=$O(^ATXAX("B","BGP HEPATITIS CPTS",0))
S BGP10743=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) S Z=$P($$CPT^ICPTCOD(Y),U,2) S:Z=90743 BGP10743=1 I $$ICD^BGP8UTL2(Y,T,1) S BGPHEP(9999999-$P(ED,"."))=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Z=$P($$CPT^ICPTCOD(Y),U,2) S:Z=90743 BGP10743=1 I $$ICD^BGP8UTL2(Y,T,1) S BGPHEP(9999999-$P(ED,"."))=""
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S X="",Y="",C=0 F S X=$O(BGPHEP(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPHEP(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPHEP=0,X=0 F S X=$O(BGPHEP(X)) Q:X'=+X S BGPHEP=BGPHEP+1
;I '$G(BGPADOL),BGPHEP=3,BGP10743 G I
I BGPHEP>2 Q 1_U_"3 Hep B"
I I BGPHEP=2,BGP10743,$G(BGPADOL) Q 1_U_" 3 Hep B"
;check for Evidence of desease and Contraindications and if yes, then quit
K BGPG S %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 4_U_"Evid Hep B"
I $$PLTAXND^BGP8DU(P,"BGP HEP EVIDENCE",EDATE) Q 4_U_"Evid Hep B"
I $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS B",EDATE) Q 4_U_"Evid Hep B"
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM="8",42,43,44,45,51,102,104,110,132,146,189 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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep B"
S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP HEPATITIS CPTS",0)))
I R,$P(R,U,3)="N" S BGPNMI=1 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep B"
;now check Refusals in imm pkg
;F BGPIMM=8,42,43,44,45,51,102,104,110,132,146 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep B"
F BGPZ=8,42,43,44,45,51,102,104,110,132,146,189 S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q 4_U_"Contra Hep B"
Q ""
HIB(P,EDATE) ;EP
K BGPC,BGPG,BGPX
K BGPHIB,BGPAHIB
;get all immunizations
S C="17^22^46^47^48^49^50^51^102^120^132^146"
D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPHIB(X)="",BGPAHIB(X)=""
;now get cpts
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737) S BGPHIB(9999999-$P(ED,"."))="",BGPAHIB(9999999-$P(ED,"."))=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737) S BGPHIB(9999999-$P(ED,"."))="",BGPAHIB(9999999-$P(ED,"."))=""
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S X="",Y="",C=0 F S X=$O(BGPHIB(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPHIB(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPHIB=0,X=0 F S X=$O(BGPHIB(X)) Q:X'=+X S BGPHIB=BGPHIB+1
I BGPHIB>2 Q 1_U_"3 Hib"
;now get povs
K BGPHIB M BGPHIB=BGPAHIB
K BGPG S %=P_"^ALL DX [BGP HIB IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPHIB($P(BGPG(X),U))="",BGPAHIB($P(BGPG(X),U))=""
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S X="",Y="",C=0 F S X=$O(BGPHIB(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPHIB(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPHIB=0,X=0 F S X=$O(BGPHIB(X)) Q:X'=+X S BGPHIB=BGPHIB+1
I BGPHIB>2 Q 2_U_"3 Hib"
;check for Evidence of desease and Contraindications and if yes, then quit
;
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=22,46,47,48,49,50,51,102,120,132,146 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",1:"Ref")_" Hib"
S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP HIB CPT",0)))
I R S:$P(R,U,3)="N" BGPNMI=1 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hib"
;now check Refusals in imm pkg
F BGPIMM=17,22,46,47,48,49,50,51,102,120,132,146 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hib"
F BGPZ=17,22,46,47,48,49,50,51,102,120,132,146 S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q 4_U_"Contra Hib"
Q ""
PNEUMO(P,EDATE,MINN) ;EP
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPPNU,BGPAPNU
;get all immunizations
S C="33^100^109^133^152"
D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPPNU(X)="",BGPAPNU(X)=""
;now get cpts
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I $$ICD^BGP8UTL2($P(^AUPNVCPT(X,0),U),$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1) S BGPPNU(9999999-$P(ED,"."))="",BGPAPNU(9999999-$P(ED,"."))=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Y=$P($$CPT^ICPTCOD(Y),U,2) I $$ICD^BGP8UTL2($P(^AUPNVTC(X,0),U),$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1) S BGPPNU(9999999-$P(ED,"."))="",BGPAPNU(9999999-$P(ED,"."))=""
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S X="",Y="",C=0 F S X=$O(BGPPNU(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPPNU(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPPNU=0,X=0 F S X=$O(BGPPNU(X)) Q:X'=+X S BGPPNU=BGPPNU+1
I BGPPNU>(MINN-1) Q 1_U_MINN_" Pneumo"
;now get povs
K BGPPNU M BGPPNU=BGPAPNU
K BGPG S %=P_"^ALL DX [BGP PNEUMO IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPPNU($P(BGPG(X),U))="",BGPAPNU($P(BGPG(X),U))=""
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S X="",Y="",C=0 F S X=$O(BGPPNU(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPPNU(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPPNU=0,X=0 F S X=$O(BGPPNU(X)) Q:X'=+X S BGPPNU=BGPPNU+1
I BGPPNU>(MINN-1) Q 2_U_MINN_" Pneumo/DX"
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=33,100,109,133,152 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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Pneumo"
S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),"N")
I R,$P(R,U,3)="N" S BGPNMI=1 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Pneumo"
;now check Refusals in imm pkg
;F BGPIMM=33,100,109,133 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Pneumo"
F BGPZ=33,100,109,133,152 S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q 4_U_"Contra Pneumo"
Q ""
EVIDVAR(P,C,ED) ;EP - HX CHICKEN POX, IMMUNE
NEW X
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.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
.I $P(^BICONT(R,0),U,1)="Hx of Chicken Pox" S G=D_U_"Contra: Hx of Chicken Pox"
.I $P(^BICONT(R,0),U,1)="Immune" S G=D_U_"Contra: Immune"
Q G
BGP8D35 ;IHS/CMI/LAB - MEASURE LOGIC;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
VAR(P,EDATE) ;EP
+1 NEW BGPC,BGPG,BGPX,BGPVARI,C,ED,BD,G,V,X,Y,BGPZ,B,BGPIMM,R,BGPNMI
+2 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+3 KILL BGPVARI
+4 ;get all immunizations
+5 SET C="21^94"
+6 DO GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
+7 ;go through and set into array if 10 days apart
+8 IF $ORDER(BGPX(0))
QUIT 1_U_"Vari"
+9 ;now get cpts
+10 SET ED=9999999-EDATE-1
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+11 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+12 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90710!(Y=90716)
SET BGPVARI(9999999-$PIECE(ED,"."))=""
End DoDot:3
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90710!(Y=90716)
SET BGPVARI(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF $DATA(BGPVARI)
QUIT 1_U_"Vari"
+19 KILL BGPG
SET %=P_"^ALL DX [BGP VARICELLA IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+20 IF $DATA(BGPG(1))
QUIT 2_U_"Vari"
+21 ;check for Evidence of desease and Contraindications and if yes, then quit
+22 KILL BGPG
SET %=P_"^LAST DX [BGP VARICELLA EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+23 IF $DATA(BGPG(1))
QUIT 4_U_"Evid Vari"
+24 IF $$PLTAXND^BGP8DU(P,"BGP VARICELLA EVIDENCE",EDATE)
QUIT 4_U_"Evid Vari"
+25 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP VARICELLA",EDATE)
QUIT 4_U_"Evid Vari"
+26 FOR BGPZ=21,94
SET X=$$EVIDVAR(P,BGPZ,EDATE)
IF X]""
QUIT
+27 IF X]""
QUIT 4_U_"Evid Vari"
+28 SET BGPZ=$$IMMUNO^BGP8D36(P,EDATE)
IF BGPZ
QUIT 4_U_"Contra Vari"
+29 SET BGPZ=$$HIVDX^BGP8D24A(P,$$DOB^AUPNPAT(P),EDATE)
IF BGPZ
QUIT 4_U_"Contra Vari"
+30 SET BGPZ=$$LYMPHO^BGP8D36(P,EDATE)
IF BGPZ
QUIT 4_U_"Contra Vari"
+31 FOR BGPZ=21,94
SET X=$$MMRCONT^BGP8D31(P,BGPZ,EDATE)
IF X]""
QUIT
+32 IF X]""
QUIT 4_U_"Contra Vari"
+33 ;now go to Refusals
+34 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+35 FOR BGPIMM=21,94
Begin DoDot:1
+36 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+37 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
+38 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Vari",1:"Ref Vari")
+39 FOR BGPIMM=90710,90716
Begin DoDot:1
+40 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+41 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
+42 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Vari",1:"Ref Vari")
+43 ;now check Refusals in imm pkg
+44 ;F BGPIMM=21,94 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+45 ;I R Q 3_U_"Ref imm pkg Vari"
+46 QUIT ""
HEP(P,EDATE) ;EP
+1 NEW BGPC,BGPG,BGPX,BGPHEP,X,ED,BD,G,T,BGP10743,V,Z,Y,C
+2 SET BGP10743=""
+3 ;get all immunizations
+4 SET C="8^42^43^44^45^51^102^104^110^132^146^189"
+5 DO GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
+6 ;go through and set into array if 10 days apart
+7 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPHEP(X)=""
+8 ;now get cpts
+9 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+10 SET T=$ORDER(^ATXAX("B","BGP HEPATITIS CPTS",0))
+11 SET BGP10743=0
FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+12 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90743
SET BGP10743=1
IF $$ICD^BGP8UTL2(Y,T,1)
SET BGPHEP(9999999-$PIECE(ED,"."))=""
End DoDot:3
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90743
SET BGP10743=1
IF $$ICD^BGP8UTL2(Y,T,1)
SET BGPHEP(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+19 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPHEP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+20 IF C=1
SET Y=X
QUIT
+21 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPHEP(X)
QUIT
+22 SET Y=X
End DoDot:1
+23 ;now count them and see if there are 4 of them
+24 SET BGPHEP=0
SET X=0
FOR
SET X=$ORDER(BGPHEP(X))
IF X'=+X
QUIT
SET BGPHEP=BGPHEP+1
+25 ;I '$G(BGPADOL),BGPHEP=3,BGP10743 G I
+26 IF BGPHEP>2
QUIT 1_U_"3 Hep B"
I IF BGPHEP=2
IF BGP10743
IF $GET(BGPADOL)
QUIT 1_U_" 3 Hep B"
+1 ;check for Evidence of desease and Contraindications and if yes, then quit
+2 KILL BGPG
SET %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT 4_U_"Evid Hep B"
+4 IF $$PLTAXND^BGP8DU(P,"BGP HEP EVIDENCE",EDATE)
QUIT 4_U_"Evid Hep B"
+5 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS B",EDATE)
QUIT 4_U_"Evid Hep B"
+6 ;now go to Refusals
+7 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+8 FOR BGPIMM="8",42,43,44,45,51,102,104,110,132,146,189
Begin DoDot:1
+9 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+10 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
+11 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Hep B"
+12 SET R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP HEPATITIS CPTS",0)))
+13 IF R
IF $PIECE(R,U,3)="N"
SET BGPNMI=1
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Hep B"
+14 ;now check Refusals in imm pkg
+15 ;F BGPIMM=8,42,43,44,45,51,102,104,110,132,146 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+16 ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep B"
+17 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=8,42,43,44,45,51,102,104,110,132,146,189
SET X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
IF X]""
QUIT
+18 IF X]""
QUIT 4_U_"Contra Hep B"
+19 QUIT ""
HIB(P,EDATE) ;EP
+1 KILL BGPC,BGPG,BGPX
+2 KILL BGPHIB,BGPAHIB
+3 ;get all immunizations
+4 SET C="17^22^46^47^48^49^50^51^102^120^132^146"
+5 DO GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
+6 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPHIB(X)=""
SET BGPAHIB(X)=""
+7 ;now get cpts
+8 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+13 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737)
SET BGPHIB(9999999-$PIECE(ED,"."))=""
SET BGPAHIB(9999999-$PIECE(ED,"."))=""
End DoDot:3
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737)
SET BGPHIB(9999999-$PIECE(ED,"."))=""
SET BGPAHIB(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+17 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPHIB(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 BGPHIB(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 ;now count them and see if there are 4 of them
+22 SET BGPHIB=0
SET X=0
FOR
SET X=$ORDER(BGPHIB(X))
IF X'=+X
QUIT
SET BGPHIB=BGPHIB+1
+23 IF BGPHIB>2
QUIT 1_U_"3 Hib"
+24 ;now get povs
+25 KILL BGPHIB
MERGE BGPHIB=BGPAHIB
+26 KILL BGPG
SET %=P_"^ALL DX [BGP HIB IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+27 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPHIB($PIECE(BGPG(X),U))=""
SET BGPAHIB($PIECE(BGPG(X),U))=""
+28 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+29 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPHIB(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+30 IF C=1
SET Y=X
QUIT
+31 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPHIB(X)
QUIT
+32 SET Y=X
End DoDot:1
+33 ;now count them and see if there are 4 of them
+34 SET BGPHIB=0
SET X=0
FOR
SET X=$ORDER(BGPHIB(X))
IF X'=+X
QUIT
SET BGPHIB=BGPHIB+1
+35 IF BGPHIB>2
QUIT 2_U_"3 Hib"
+36 ;check for Evidence of desease and Contraindications and if yes, then quit
+37 ;
+38 ;now go to Refusals
+39 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+40 FOR BGPIMM=22,46,47,48,49,50,51,102,120,132,146
Begin DoDot:1
+41 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+42 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
+43 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Hib"
+44 SET R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP HIB CPT",0)))
+45 IF R
IF $PIECE(R,U,3)="N"
SET BGPNMI=1
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Hib"
+46 ;now check Refusals in imm pkg
+47 FOR BGPIMM=17,22,46,47,48,49,50,51,102,120,132,146
SET R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+48 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Hib"
+49 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=17,22,46,47,48,49,50,51,102,120,132,146
SET X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
IF X]""
QUIT
+50 IF X]""
QUIT 4_U_"Contra Hib"
+51 QUIT ""
PNEUMO(P,EDATE,MINN) ;EP
+1 KILL BGPC,BGPG,BGPX
+2 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+3 KILL BGPPNU,BGPAPNU
+4 ;get all immunizations
+5 SET C="33^100^109^133^152"
+6 DO GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
+7 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPPNU(X)=""
SET BGPAPNU(X)=""
+8 ;now get cpts
+9 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+10 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+11 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+14 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF $$ICD^BGP8UTL2($PIECE(^AUPNVCPT(X,0),U),$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1)
SET BGPPNU(9999999-$PIECE(ED,"."))=""
SET BGPAPNU(9999999-$PIECE(ED,"."))=""
End DoDot:3
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+16 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF $$ICD^BGP8UTL2($PIECE(^AUPNVTC(X,0),U),$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1)
SET BGPPNU(9999999-$PIECE(ED,"."))=""
SET BGPAPNU(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+18 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPPNU(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+19 IF C=1
SET Y=X
QUIT
+20 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPPNU(X)
QUIT
+21 SET Y=X
End DoDot:1
+22 ;now count them and see if there are 4 of them
+23 SET BGPPNU=0
SET X=0
FOR
SET X=$ORDER(BGPPNU(X))
IF X'=+X
QUIT
SET BGPPNU=BGPPNU+1
+24 IF BGPPNU>(MINN-1)
QUIT 1_U_MINN_" Pneumo"
+25 ;now get povs
+26 KILL BGPPNU
MERGE BGPPNU=BGPAPNU
+27 KILL BGPG
SET %=P_"^ALL DX [BGP PNEUMO IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+28 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPPNU($PIECE(BGPG(X),U))=""
SET BGPAPNU($PIECE(BGPG(X),U))=""
+29 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+30 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPPNU(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+31 IF C=1
SET Y=X
QUIT
+32 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPPNU(X)
QUIT
+33 SET Y=X
End DoDot:1
+34 ;now count them and see if there are 4 of them
+35 SET BGPPNU=0
SET X=0
FOR
SET X=$ORDER(BGPPNU(X))
IF X'=+X
QUIT
SET BGPPNU=BGPPNU+1
+36 IF BGPPNU>(MINN-1)
QUIT 2_U_MINN_" Pneumo/DX"
+37 ;now go to Refusals
+38 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+39 FOR BGPIMM=33,100,109,133,152
Begin DoDot:1
+40 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+41 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
+42 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Pneumo"
+43 SET R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),"N")
+44 IF R
IF $PIECE(R,U,3)="N"
SET BGPNMI=1
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Pneumo"
+45 ;now check Refusals in imm pkg
+46 ;F BGPIMM=33,100,109,133 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+47 ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Pneumo"
+48 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=33,100,109,133,152
SET X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
IF X]""
QUIT
+49 IF X]""
QUIT 4_U_"Contra Pneumo"
+50 QUIT ""
EVIDVAR(P,C,ED) ;EP - HX CHICKEN POX, IMMUNE
+1 NEW X
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Hx of Chicken Pox"
SET G=D_U_"Contra: Hx of Chicken Pox"
+11 IF $PIECE(^BICONT(R,0),U,1)="Immune"
SET G=D_U_"Contra: Immune"
End DoDot:1
+12 QUIT G
