BGP4D3B ; IHS/CMI/LAB - PNEUMO REMINDER ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
I13 ;EP - PN
NEW BGPTDAP,BGPTD,BGPFLU,BGPZOST
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13)=0
S (BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22)=0
I BGPAGEB>64,BGPACTUP S BGPD3=1
I BGPDMD2 S BGPD2=1
I BGPAGEB>64,BGPACTCL S BGPD1=1
I BGPAGEB>17,BGPAGEB<65,BGPACTCL,$$HIGHRP^BGP4D3A(DFN,BGPEDATE) S BGPD4=1
I BGPAGEB>17,BGPAGEB<65,BGPACTUP,$$HIGHRP^BGP4D3A(DFN,BGPEDATE) S BGPD5=1
I BGPAGEB>17,BGPAGEB<65,BGPACTCL S BGPD6=1
I BGPAGEB>17,BGPAGEB<65,BGPACTUP S BGPD7=1
I BGPAGEB>17,BGPACTCL S BGPD8=1
I BGPAGEB>17,BGPACTUP S BGPD9=1
I BGPAGEB>18,BGPAGEB<60,BGPACTCL S BGPD10=1
I BGPAGEB>18,BGPAGEB<60,BGPACTUP S BGPD11=1
I BGPAGEB>59,BGPAGEB<65,BGPACTCL S BGPD12=1
I BGPAGEB>59,BGPAGEB<65,BGPACTUP S BGPD13=1
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13) S BGPSTOP=1 Q
I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q
PN ;EP - called from elder
S BGPVALUE=$$PNEU^BGP4D31(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;set to date of PNEU shot
;I BGPVALUE]"" S BGPN1=1
I $P(BGPVALUE,U,3)=1!($P(BGPVALUE,U,3)=3) S BGPN1=1
;I $P(BGPVALUE,U,3)=2 S BGPN2=1 ;REF
I $P(BGPVALUE,U,3)=3 S BGPN3=1 ;NMI
S BGPVAL=$$PNEU^BGP4D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
I $P(BGPVAL,U,3)=1!($P(BGPVAL,U,3)=3) S BGPN4=1 ;HAD IN PAST 5 YEARS SO "UP TO DATE"
;I $P(BGPVAL,U,3)=2 S BGPN5=1
I $P(BGPVAL,U,3)=3 S BGPN6=1
S BGPN7=0,BGPA65="" I BGPAGEB>65 S BGPA65=$$PNEU^BGP4D31(DFN,$$FMADD^XLFDT($$DOB^AUPNPAT(DFN),+(65*365)),BGPEDATE) I $P(BGPA65,U,3)=1!($P(BGPA65,U,3)=3) S BGPN4=1,BGPN7=1 ;over 65 and had one after 65
I BGPAGEB<65,BGPN1 S BGPN4=1 ;anyone under and had 1 ever
;GPRA DEVELOPMENTAL
S BGPN8=0
I BGPAGEB<66,BGPN1 S BGPN8=1
I BGPAGEB>65,BGPN1,(BGPN4+BGPN7) S BGPN8=1 ;IF UNDER 66 HAD 1 EVER, IF OVER 65 HAD ONE IN PAST 5 YEARS OR AFTER AGE 65
S BGPDV=""
I BGPRTYPE=1 S BGPDV="" D
.I BGPD1 S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
.I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
.I BGPN1 S BGPVALH=BGPVALUE,BGPVALUE=BGPDV_"|||" I BGPVALH]"" S BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP4UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]"":" (ever)",1:"")_" "_$S(BGPN8:" (up-to-date)",1:"") Q
.S BGPVALUE=BGPDV_"|||"
I BGPRTYPE=4 D
.S BGPDV="UP"
.I BGPD6!(BGPD1)!(BGPD8) S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
.I BGPD4!(BGPD5) S BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR")
.;I BGPD3 S BGPDV=BGPDV_$S(BGPDV]"":",UP >64",1:"UP >64")
.;I BGPD7 S BGPDV=BGPDV_$S(BGPDV]"":",UP 18-64",1:"UP 18-64")
.;I BGPD5 S BGPDV=BGPDV_$S(BGPDV]"":",UP 18-64HR",1:"UP 18-64HR")
.I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
I BGPRTYPE=7 S BGPDV=$S(BGPD6:"AC",BGPD8:"AC",1:"") S:BGPD4 BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR") S:BGPD2 BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
;I BGPRTYPE=5 S BGPVALUE="" I (BGPN8!BGPN3) S BGPVALUE="AC"_"|||"_$$DATE^BGP4UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2) I 1
D
.I BGPRTYPE'=1 S BGPVALH=BGPVALUE,BGPVALUE=BGPDV_"|||" I BGPVALH]"" S BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP4UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]"":" (ever)",1:"")_" "_$S(BGPN8:" (up-to-date)",1:"")
.S BGPVALUD="AC"_"|||"
.I BGPN4 S BGPVALUD=BGPVALUD_"Pneumo: "_$$DATE^BGP4UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]"":" (ever)",1:"")_" "
.S BGPVALUD=BGPVALUD_$S(BGPN8:"(up-to-date)",1:"")
TD ;new tdap and td stuff for v11.1
S BGPTDAP=$$DTAP^BGP4D3A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPTDAP S BGPN9=1
I $P(BGPTDAP,U,1)=2 S BGPN12=1
S BGPTD=$$DTAPTD^BGP4D3A(DFN,$$FMADD^XLFDT(BGPEDATE,-(10*365)),BGPEDATE)
I BGPTD S BGPN10=1
I $P(BGPTD,U,1)=2 S BGPN11=1
I BGPRTYPE=5 G TDE
;FLU - 14.1
S BGPFLU=$$FLU^BGP4D3(DFN,,BGPEDATE)
I $P(BGPFLU,U,3)=1!($P(BGPFLU,U,3)=3) S BGPN13=1
I $P(BGPFLU,U,3)=3 S BGPN14=1
I BGPN9,BGPN10,BGPN13 S BGPN15=1
I BGPN11!(BGPN12)!(BGPN14) S BGPN16=1
S BGPZOST=$$IZOSTER(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I $P(BGPZOST,U,3)=1!($P(BGPZOST,U,3)=3) S BGPN17=1
I $P(BGPZOST,U,3)=3 S BGPN18=1
I BGPN9,BGPN10,BGPN13,BGPN17 S BGPN19=1
I BGPN11!(BGPN12)!(BGPN14)!(BGPN18) S BGPN20=1
I BGPN9,BGPN10,BGPN13,BGPN17,BGPN8 S BGPN21=1
I BGPN11!(BGPN12)!(BGPN14)!(BGPN18)!(BGPN3) S BGPN22=1
I BGPTDAP S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP: "_$P(BGPTDAP,U,2)_" (ever)"
I BGPTD S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP/TD: "_$P(BGPTD,U,2)_" (past 10 yrs)"
I BGPFLU S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"FLU: "_$P(BGPFLU,U,2)_" (past yr)"
I BGPZOST S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"ZOSTER: "_$P(BGPZOST,U,2)_" (ever)"
I BGPTDAP S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"TDAP: "_$P(BGPTDAP,U,2)_" (ever)"
I BGPTD S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"TDAP/TD: "_$P(BGPTD,U,2)_" (past 10 yrs)"
I BGPFLU S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"FLU: "_$P(BGPFLU,U,2)_" (past yr)"
I BGPZOST S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"ZOSTER: "_$P(BGPZOST,U,2)_" (ever)"
TDE K BGPLPNU,BGPVAL,BGPA65,BGPVALH,BGPTD,BGPTDAP,BGPFLU
Q
IZOSTER(P,BDATE,EDATE,FORE) ;EP
NEW BGPLPNU,BGPG,X,E
S BGPLPNU=""
S BD=BDATE
S ED=EDATE
S EDATE=$$FMTE^XLFDT(EDATE)
S BDATE=$$FMTE^XLFDT(BDATE)
S X=P_"^LAST IMM 121;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 121"
S %=$$CPT^BGP4DU(P,BD,ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
S %=$$TRAN^BGP4DU(P,BD,ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
I BGPLPNU]"" Q BGPLPNU_U_1
;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
F BGPZ=121 S X=$$ANIMCONT^BGP4D31(P,BGPZ,ED)
I X]"" Q X_U_3
;NMI Refusal
S G=$$NMIREF^BGP4UTL1(P,9999999.14,$O(^AUTTIMM("C",121,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
Q ""
;
BGP4D3B ; IHS/CMI/LAB - PNEUMO REMINDER ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
I13 ;EP - PN
+1 NEW BGPTDAP,BGPTD,BGPFLU,BGPZOST
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13)=0
+3 SET (BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22)=0
+4 IF BGPAGEB>64
IF BGPACTUP
SET BGPD3=1
+5 IF BGPDMD2
SET BGPD2=1
+6 IF BGPAGEB>64
IF BGPACTCL
SET BGPD1=1
+7 IF BGPAGEB>17
IF BGPAGEB<65
IF BGPACTCL
IF $$HIGHRP^BGP4D3A(DFN,BGPEDATE)
SET BGPD4=1
+8 IF BGPAGEB>17
IF BGPAGEB<65
IF BGPACTUP
IF $$HIGHRP^BGP4D3A(DFN,BGPEDATE)
SET BGPD5=1
+9 IF BGPAGEB>17
IF BGPAGEB<65
IF BGPACTCL
SET BGPD6=1
+10 IF BGPAGEB>17
IF BGPAGEB<65
IF BGPACTUP
SET BGPD7=1
+11 IF BGPAGEB>17
IF BGPACTCL
SET BGPD8=1
+12 IF BGPAGEB>17
IF BGPACTUP
SET BGPD9=1
+13 IF BGPAGEB>18
IF BGPAGEB<60
IF BGPACTCL
SET BGPD10=1
+14 IF BGPAGEB>18
IF BGPAGEB<60
IF BGPACTUP
SET BGPD11=1
+15 IF BGPAGEB>59
IF BGPAGEB<65
IF BGPACTCL
SET BGPD12=1
+16 IF BGPAGEB>59
IF BGPAGEB<65
IF BGPACTUP
SET BGPD13=1
+17 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13)
SET BGPSTOP=1
QUIT
+18 IF BGPRTYPE=3
IF 'BGPD1
SET BGPSTOP=1
QUIT
PN ;EP - called from elder
+1 ;set to date of PNEU shot
SET BGPVALUE=$$PNEU^BGP4D31(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+2 ;I BGPVALUE]"" S BGPN1=1
+3 IF $PIECE(BGPVALUE,U,3)=1!($PIECE(BGPVALUE,U,3)=3)
SET BGPN1=1
+4 ;I $P(BGPVALUE,U,3)=2 S BGPN2=1 ;REF
+5 ;NMI
IF $PIECE(BGPVALUE,U,3)=3
SET BGPN3=1
+6 SET BGPVAL=$$PNEU^BGP4D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
+7 ;HAD IN PAST 5 YEARS SO "UP TO DATE"
IF $PIECE(BGPVAL,U,3)=1!($PIECE(BGPVAL,U,3)=3)
SET BGPN4=1
+8 ;I $P(BGPVAL,U,3)=2 S BGPN5=1
+9 IF $PIECE(BGPVAL,U,3)=3
SET BGPN6=1
+10 ;over 65 and had one after 65
SET BGPN7=0
SET BGPA65=""
IF BGPAGEB>65
SET BGPA65=$$PNEU^BGP4D31(DFN,$$FMADD^XLFDT($$DOB^AUPNPAT(DFN),+(65*365)),BGPEDATE)
IF $PIECE(BGPA65,U,3)=1!($PIECE(BGPA65,U,3)=3)
SET BGPN4=1
SET BGPN7=1
+11 ;anyone under and had 1 ever
IF BGPAGEB<65
IF BGPN1
SET BGPN4=1
+12 ;GPRA DEVELOPMENTAL
+13 SET BGPN8=0
+14 IF BGPAGEB<66
IF BGPN1
SET BGPN8=1
+15 ;IF UNDER 66 HAD 1 EVER, IF OVER 65 HAD ONE IN PAST 5 YEARS OR AFTER AGE 65
IF BGPAGEB>65
IF BGPN1
IF (BGPN4+BGPN7)
SET BGPN8=1
+16 SET BGPDV=""
+17 IF BGPRTYPE=1
SET BGPDV=""
Begin DoDot:1
+18 IF BGPD1
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")
+19 IF BGPD2
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
+20 IF BGPN1
SET BGPVALH=BGPVALUE
SET BGPVALUE=BGPDV_"|||"
IF BGPVALH]""
SET BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP4UTL($PIECE(BGPVALH,U,1))_" "_$PIECE(BGPVALH,U,2)_$SELECT(BGPVALH]"":" (ever)",1:"")_" "_$SELECT(BGPN8:" (up-to-date)",1:"")
QUIT
+21 SET BGPVALUE=BGPDV_"|||"
End DoDot:1
+22 IF BGPRTYPE=4
Begin DoDot:1
+23 SET BGPDV="UP"
+24 IF BGPD6!(BGPD1)!(BGPD8)
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")
+25 IF BGPD4!(BGPD5)
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",HR",1:"HR")
+26 ;I BGPD3 S BGPDV=BGPDV_$S(BGPDV]"":",UP >64",1:"UP >64")
+27 ;I BGPD7 S BGPDV=BGPDV_$S(BGPDV]"":",UP 18-64",1:"UP 18-64")
+28 ;I BGPD5 S BGPDV=BGPDV_$S(BGPDV]"":",UP 18-64HR",1:"UP 18-64HR")
+29 IF BGPD2
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
End DoDot:1
+30 IF BGPRTYPE=7
SET BGPDV=$SELECT(BGPD6:"AC",BGPD8:"AC",1:"")
IF BGPD4
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",HR",1:"HR")
IF BGPD2
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
+31 ;I BGPRTYPE=5 S BGPVALUE="" I (BGPN8!BGPN3) S BGPVALUE="AC"_"|||"_$$DATE^BGP4UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2) I 1
+32 Begin DoDot:1
+33 IF BGPRTYPE'=1
SET BGPVALH=BGPVALUE
SET BGPVALUE=BGPDV_"|||"
IF BGPVALH]""
SET BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP4UTL($PIECE(BGPVALH,U,1))_" "_$PIECE(BGPVALH,U,2)_$SELECT(BGPVALH]"":" (ever)",1:"")_" "_$SELECT(BGPN8:" (up-to-date)",1:"")
+34 SET BGPVALUD="AC"_"|||"
+35 IF BGPN4
SET BGPVALUD=BGPVALUD_"Pneumo: "_$$DATE^BGP4UTL($PIECE(BGPVALH,U,1))_" "_$PIECE(BGPVALH,U,2)_$SELECT(BGPVALH]"":" (ever)",1:"")_" "
+36 SET BGPVALUD=BGPVALUD_$SELECT(BGPN8:"(up-to-date)",1:"")
End DoDot:1
TD ;new tdap and td stuff for v11.1
+1 SET BGPTDAP=$$DTAP^BGP4D3A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+2 IF BGPTDAP
SET BGPN9=1
+3 IF $PIECE(BGPTDAP,U,1)=2
SET BGPN12=1
+4 SET BGPTD=$$DTAPTD^BGP4D3A(DFN,$$FMADD^XLFDT(BGPEDATE,-(10*365)),BGPEDATE)
+5 IF BGPTD
SET BGPN10=1
+6 IF $PIECE(BGPTD,U,1)=2
SET BGPN11=1
+7 IF BGPRTYPE=5
GOTO TDE
+8 ;FLU - 14.1
+9 SET BGPFLU=$$FLU^BGP4D3(DFN,,BGPEDATE)
+10 IF $PIECE(BGPFLU,U,3)=1!($PIECE(BGPFLU,U,3)=3)
SET BGPN13=1
+11 IF $PIECE(BGPFLU,U,3)=3
SET BGPN14=1
+12 IF BGPN9
IF BGPN10
IF BGPN13
SET BGPN15=1
+13 IF BGPN11!(BGPN12)!(BGPN14)
SET BGPN16=1
+14 SET BGPZOST=$$IZOSTER(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+15 IF $PIECE(BGPZOST,U,3)=1!($PIECE(BGPZOST,U,3)=3)
SET BGPN17=1
+16 IF $PIECE(BGPZOST,U,3)=3
SET BGPN18=1
+17 IF BGPN9
IF BGPN10
IF BGPN13
IF BGPN17
SET BGPN19=1
+18 IF BGPN11!(BGPN12)!(BGPN14)!(BGPN18)
SET BGPN20=1
+19 IF BGPN9
IF BGPN10
IF BGPN13
IF BGPN17
IF BGPN8
SET BGPN21=1
+20 IF BGPN11!(BGPN12)!(BGPN14)!(BGPN18)!(BGPN3)
SET BGPN22=1
+21 IF BGPTDAP
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"TDAP: "_$PIECE(BGPTDAP,U,2)_" (ever)"
+22 IF BGPTD
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"TDAP/TD: "_$PIECE(BGPTD,U,2)_" (past 10 yrs)"
+23 IF BGPFLU
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"FLU: "_$PIECE(BGPFLU,U,2)_" (past yr)"
+24 IF BGPZOST
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"ZOSTER: "_$PIECE(BGPZOST,U,2)_" (ever)"
+25 IF BGPTDAP
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"TDAP: "_$PIECE(BGPTDAP,U,2)_" (ever)"
+26 IF BGPTD
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"TDAP/TD: "_$PIECE(BGPTD,U,2)_" (past 10 yrs)"
+27 IF BGPFLU
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"FLU: "_$PIECE(BGPFLU,U,2)_" (past yr)"
+28 IF BGPZOST
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"ZOSTER: "_$PIECE(BGPZOST,U,2)_" (ever)"
TDE KILL BGPLPNU,BGPVAL,BGPA65,BGPVALH,BGPTD,BGPTDAP,BGPFLU
+1 QUIT
IZOSTER(P,BDATE,EDATE,FORE) ;EP
+1 NEW BGPLPNU,BGPG,X,E
+2 SET BGPLPNU=""
+3 SET BD=BDATE
+4 SET ED=EDATE
+5 SET EDATE=$$FMTE^XLFDT(EDATE)
+6 SET BDATE=$$FMTE^XLFDT(BDATE)
+7 SET X=P_"^LAST IMM 121;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+8 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 121"
+9 SET %=$$CPT^BGP4DU(P,BD,ED,$ORDER(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
+10 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+11 SET %=$$TRAN^BGP4DU(P,BD,ED,$ORDER(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
+12 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+13 IF BGPLPNU]""
QUIT BGPLPNU_U_1
+14 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
+15 FOR BGPZ=121
SET X=$$ANIMCONT^BGP4D31(P,BGPZ,ED)
+16 IF X]""
QUIT X_U_3
+17 ;NMI Refusal
+18 SET G=$$NMIREF^BGP4UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",121,0)),$$DOB^AUPNPAT(P),ED)
+19 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+20 QUIT ""
+21 ;
