- 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 ;