BIPATUP1 ;IHS/CMI/MWR - UPDATE PATIENT DATA; DEC 15, 2011
;;8.5;IMMUNIZATION;**14**;AUG 01,2017
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; UPDATE PATIENT DATA, IMM FORECAST IN ^BIPDUE(.
;; PATCH 8: Extensive changes to accommodate new TCH Forecaster LDFORC+0
;; PATCH 9: Numerous changes to accomodate new Heb B High Risk IHSPOST+0
;; PATCH 10: Recognize both TCH incoming 33 PNEUMO-PS or 133 PCV-13. DDUE2+56
;; PATCH 12: If Dose Override is Invalid (1-4) forecast Pneumo. IHSPOST+30
;; PATCH 13: Do not forecast Flu before local Flu Season Start Date. DDUE2+46
;; PATCH 14: Mods to add IHS Forecast Addendum to TCH Report. LDFORC+0, IHSPOST+0
;; Only CVX 33 should satisfy Pneumo High Risk. IHSPOST+39
;
;
;********** PATCH 14, v8.5, AUG 01,2017, IHS/CMI/MWR
;---> IHS Forecast Addendum to TCH Report.
;----------
LDFORC(BIDFN,BIFORC,BIHX,BIFDT,BIDUZ2,BINF,BIPDSS,BIADDND) ;EP
;---> Load Immserve Data (Immunizations Due) into ^BIPDUE(.
;---> Parameters:
; 1 - BIDFN (req) Patient IEN.
; 2 - BIFORC (req) String containing Patient's Imms Due.
; 3 - BIHX (req) String containing Patient's Imm History.
; 4 - BIFDT (opt) Forecast Date (date used for forecast).
; 5 - BIDUZ2 (opt) User's DUZ(2) indicating site parameters.
; 6 - BINF (opt) Array of Vaccine Grp IEN'S that should not be forecast.
; 7 - BIPDSS (ret) Returned string of V IMM IEN's that are
; Problem Doses, according to ImmServe.
; 8 - BIADDND(ret) IHS forecasting addendum (to be added to TCH Report).
;
Q:'$G(BIDFN) Q:$G(BIFORC)="" Q:$G(BIHX)=""
;---> If no Forecast Date passed, set it equal to today.
S:'$G(BIFDT) BIFDT=DT S:'$D(BINF) BINF=""
;
;---> First clear out any previously set Immunizations Due and
;---> any Forecasting Errors for this patient.
D KILLDUE^BIPATUP2(BIDFN)
;
;---> If no BIDUZ2, try DUZ(2); otherwise, defaults will be used.
S:'$G(BIDUZ2) BIDUZ2=$G(DUZ(2))
;
;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
;---> Check for any input doses that TCH identified as problems.
;---> Build and return a string of "V IMM IEN_%_CVX" problem doses,
;---> as identified in the TCH Input Doses segment.
D DPROBS^BIPATUP2(BIFORC,.BIPDSS)
;**********
;
;---> Seed BITCHAF to collect
N BITCHAF S BITCHAF=""
;
;---> Parse Doses Due from Forecaster string (BIFORC), perform any
;---> necessary translations, and set as due in patient global ^BIPDUE(.
D DDUE(BIFORC,BIHX,.BINF,BIDUZ2,BIFDT,.BITCHAF)
;
;---> After loading (SETDUE) TCH forecast, perform any follow-up forecasting
;---> needed for High Risk, "Post-forecast".
D IHSPOST(BIDFN,BIHX,BIFDT,BIDUZ2,.BINF,BITCHAF,.BIADDND)
;
Q
;
;
;----------
DDUE(BIFORC,BIHX,BINF,BIDUZ2,BIFDT,BITCHAF) ;EP
;---> Parse Doses Due from Immserve string (BIFORC), perform any
;---> necessary translations, and set as due in patient global ^BIPDUE.
;---> Parameters:
; 1 - BIFORC (req) Forecast string coming back from TCH.
; 2 - BIHX (req) String containing Patient's Imm History.
; 3 - BINF (opt) Array of Vaccine Grp IEN'S that should not be forecast.
; 4 - BIDUZ2 (opt) User's DUZ(2) indicating site parameters.
; 5 - BIFDT (opt) Forecast Date (date used for forecast).
; 6 - BITCHAF (ret) [1=TCH Already Forecast Pneumo (33), [2=HepB(45), [3=HepA(85).
;
;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
;---> Changes to accommodate new TCH Forecaster parsing.
N BIFORC1,BIDOSE,N
S BIFORC1=$P(BIFORC,"~~~",3)
;
F N=1:1 S BIDOSE=$P(BIFORC1,"|||",N) Q:(BIDOSE="") D
.D DDUE2(BIDOSE,BIHX,.BINF,.BIPC,BIDUZ2,BIFDT,.BITCHAF)
Q
;
;
;----------
DDUE2(BIDOSE,BIHX,BINF,BIPC,BIDUZ2,BIFDT,BITCHAF) ;EP
;---> Parse Doses Due (see linelabel DDUE above).
;---> Parameters: See DDUE immediately above!
;
;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
;---> Many changes below to accommodate new TCH Forecaster.
;
;---> Uncomment next line to see raw Doses Due:
;W !!!,BIDOSE R ZZZ
;
N A,BI,D,X S X=BIDOSE
;---> A=CVX Code
S A=$P(X,U,1)
;
;---> "PAST"=Past Due Indicator
S BI("PAST")=$P(X,U,3)
;
;---> Get Fileman formats of due dates.
;---> "MIN"=Minimum Date Due
S BI("MIN")=$$TCHFMDT^BIUTL5($P(X,U,4)) S:('BI("MIN")) BI("MIN")=""
;
;---> "REC"=Recommended Date Due
S BI("REC")=$$TCHFMDT^BIUTL5($P(X,U,5)) S:('BI("REC")) BI("REC")=""
;
;---> "EXC"=Exceeds Date Due
S BI("EXC")=$$TCHFMDT^BIUTL5($P(X,U,6)) S:('BI("EXC")) BI("EXC")=""
;
;---> Determine whether to set Recommended Age or Minimum Accepted Age
;---> based on Site Parameter.
S BI("DUE")=BI("REC")
I $$MINAGE^BIUTL2($G(BIDUZ2))=1 S BI("DUE")=BI("MIN")
;
;---> If this dose is past due (BI("PAST")=1), D(2) will stuff DATE PAST DUE;
;---> Otherwise, D(1) will stuff RECOMMENDED DATE DUE.
S (D(1),D(2))="" D
.I BI("PAST") S D(2)=BI("EXC") Q
.S D(1)=BI("DUE")
;
;---> *** TRANSLATIONS OF INCOMING IMMSERVE VACCINES:
;---> -------------------------------------------
Q:A=""
;
;---> Check to see if Site specified do not forecast this Vaccine Group.
Q:$D(BINF($$HL7TX^BIUTL2(A,1)))
;
;
;********** PATCH 13, v8.5, AUG 01,2016, IHS/CMI/MWR
;---> Do not forecast Flu (CVX 88) before local Flu Season Start Date, regardless of
;---> Min vs. Rec site parameter #8.
I A=88,$E($G(BIFDT),4,5)>6 Q:(BIFDT<($E(BIFDT,1,3)_$TR($P($$FLUDATS^BIUTL8(BIDUZ2),"%"),"/")))
;**********
;
;---> Add this Immunization Due.
D SETDUE^BIPATUP2(BIDFN_U_$$HL7TX^BIUTL2(A)_U_U_D(1)_U_D(2))
;
;********** PATCH 14, v8.5, AUG 01,2017, IHS/CMI/MWR
;---> Use BITCHAF to track TCH forecasting of Pneumo, Hep A and Hep B.
;
;---> Pneumo 33 OR 133 was forecast by TCH.
I (A=33)!(A=133) S BITCHAF=BITCHAF_1
;---> Hep B was forecast by TCH.
I A=45 S BITCHAF=BITCHAF_2
;---> Hep A was forecast by TCH.
I A=85 S BITCHAF=BITCHAF_3
;
Q
;
;
;********** PATCH 14, v8.5, AUG 01,2017, IHS/CMI/MWR
;---> Extensive changes.
;----------
IHSPOST(BIDFN,BIHX,BIFDT,BIDUZ2,BINF,BITCHAF,BIADDND) ;EP
;---> Post forecast; after loading TCH forecast, perform any follow-up forecasting
;---> needed for High Risk.
;---> Parameters:
; 1 - BIDFN (req) Patient IEN.
; 2 - BIHX (req) String containing Patient's Imm History.
; 3 - BIFDT (req) Forecast Date (date used for forecast).
; 4 - BIDUZ2 (req) User's DUZ(2) for High Risk Site Parameter.
; 5 - BINF (opt) Array of Vaccine Grp IEN'S that should not be forecast.
; 6 - BIADDND (ret) IHS forecasting addendum (to be added to TCH Report).
;
;---> Loop through History string, gathering previous Influenzas and Pneumos.
;
N BIDOSE,BIFLU,BIHX1,I,X,Y
S BIHX1=$P(BIHX,"~~~",2)
;
;---> Loop through RPMS Input String History, collecting for prior Pneumo.
;---> Store in BIFLU by HL7 Code, inverse date.
;F I=1:1:Y D
F I=1:1 S BIDOSE=$P(BIHX1,"|||",I) Q:BIDOSE="" D
.;
.;---> For this Immunization, set A=CVX Code, D=Date.
.N A,D S A=$P(BIDOSE,U,2),D=$P(BIDOSE,U,3)
.;
.;---> Quit if Dose Override is Invalid (1-4).
.I $P(BIDOSE,U,4),$P(BIDOSE,U,4)<9 Q
.;
.;---> If this is Hep B or Hep A,
.;---> translate and store it in local array BIFLU(CVX,Inverse Fm date).
.;---> (Pneumo (33,100,109,133,152) not translated.)
.;
.;---> Collect Hep B CVX's.
.S:((A=8)!(A=42)!(A=44)!(A=43)!(A=43)!(A=51)!(A=102)) A=45
.S:((A=104)!(A=110)!(A=132)!(A=146)) A=45
.;
.;---> Collect Hep A CVX's.
.S:((A=31)!(A=52)!(A=83)!(A=84)!(A=104)!(A=169)) A=85
.;
.;---> Save any Pneumo, Hep B, or Hep A.
.D:((A=33)!(A=100)!(A=109)!(A=133)!(A=152)!(A=45)!(A=85))
..S BIFLU(A,9999999-$$TCHFMDT^BIUTL5(D))=""
;
;
;---> Check for THIS PATIENT: forced Pneumo or Disregard all Risk Factors.
;---> BIFFLU: 0=Normal, 1=not used, 2=Force Pneumo, 3=not used, 4=Disregard Risk Factors.
S BIFFLU=$$INFL^BIUTL11(BIDFN)
;---> Quit (don't check Risk Factors) if BIFFLU=4, Disregard Risk Factors for this patient.
Q:BIFFLU=4
;
;---> Quit if SITE PARAMETER says NOT to include any Risk Factors in forecast (returns 0).
N BIRISK S BIRISK=$$RISKP^BIUTL2(BIDUZ2)
Q:'BIRISK
;
S:'$G(BIFDT) BIFDT=$G(DT)
;
;---> Set Patient Age in years for this Forecast Date.
N BIAGE S BIAGE=$$AGE^BIUTL1(BIDFN,1,BIFDT)
;
;---> No High Risk computation under 19 years.
Q:(BIAGE<19)
;
;
;---> * * * Forecast Pneumo for High Risk if needed. * * *
D
.;---> Quit if CVX 33 is in the history (satisfies both Early Pneumo and High Risk.)
.Q:($D(BIFLU(33)))
.;
.;---> Quit if TCH already forecast Pneumo (33).
.Q:(BITCHAF[1)
.;---> Quit if Site Parameter does not include Pneumo.
.Q:(BIRISK'[1)
.;---> Check if Site Parameter includes Smoking (includes 9).
.N BIRISKF,BISMKR S BISMKR=$S(BIRISK[9:1,1:0)
.;---> Check for High Risk.
.D RISKP^BIDX(BIDFN,BIFDT,BIAGE,BISMKR,.BIRISKF)
.;
.;---> Set Early Forecast or High Risk if needed.
.D IHSPNEU^BIPATUP3(BIDFN,.BIFLU,BIFFLU,.BINF,BIFDT,BIAGE,BIDUZ2,BIRISKF,.BIADDND)
;
;
;---> * * * Forecast Hep B for Diabetes if needed. * * *
D
.;---> Quit if Hep B (45) is in the history, ever received a Hep B.
.Q:($D(BIFLU(45)))
.;---> Quit if TCH already forecast Hep B (45).
.Q:(BITCHAF[2)
.;---> Quit if Site Parameter does not include Hep B for Diabetes.
.Q:(BIRISK'[2)
.;---> Quit if this Pt Age is older than 60 yrs, regardless of risk.
.Q:(BIAGE>59)
.;---> Check for High Risk.
.N BIRISKF
.D RISKB^BIDX(BIDFN,BIFDT,BIAGE,.BIRISKF)
.Q:'BIRISKF
.;---> Set Early Forecast or High Risk if needed.
.D IHSHEPB^BIPATUP3(BIDFN,.BINF,BIFDT,1,.BIADDND)
.S BITCHAF=BITCHAF_2
;
;
;---> * * * Forecast Hep A & B for CLD/HepC if needed. * * *
D
.;---> Quit if Hep A (85) and Hep B (45) are BOTH in the history.
.Q:($D(BIFLU(85))&$D(BIFLU(45)))
.;---> Quit if Site Parameter does not include Hep A&B for CLD/HepC.
.Q:(BIRISK'[3)
.;
.;---> Check for High Risk.
.N BIRISKF
.D RISKAB^BIDX(BIDFN,BIFDT,.BIRISKF)
.Q:'BIRISKF
.;
.;---> If TCH did NOT already forecast Hep B (45), forecast Hep B for CLD/HepC.
.I ('$D(BIFLU(45)))&(BITCHAF'[2) D IHSHEPB^BIPATUP3(BIDFN,.BINF,BIFDT,2,.BIADDND)
.;
.;---> If TCH did NOT already forecast Hep A (85), forecast Hep A for CLD/HepC.
.I ('$D(BIFLU(85)))&(BITCHAF'[3) D IHSHEPA^BIPATUP3(BIDFN,.BINF,BIFDT,,.BIADDND)
;
Q
BIPATUP1 ;IHS/CMI/MWR - UPDATE PATIENT DATA; DEC 15, 2011
+1 ;;8.5;IMMUNIZATION;**14**;AUG 01,2017
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; UPDATE PATIENT DATA, IMM FORECAST IN ^BIPDUE(.
+4 ;; PATCH 8: Extensive changes to accommodate new TCH Forecaster LDFORC+0
+5 ;; PATCH 9: Numerous changes to accomodate new Heb B High Risk IHSPOST+0
+6 ;; PATCH 10: Recognize both TCH incoming 33 PNEUMO-PS or 133 PCV-13. DDUE2+56
+7 ;; PATCH 12: If Dose Override is Invalid (1-4) forecast Pneumo. IHSPOST+30
+8 ;; PATCH 13: Do not forecast Flu before local Flu Season Start Date. DDUE2+46
+9 ;; PATCH 14: Mods to add IHS Forecast Addendum to TCH Report. LDFORC+0, IHSPOST+0
+10 ;; Only CVX 33 should satisfy Pneumo High Risk. IHSPOST+39
+11 ;
+12 ;
+13 ;********** PATCH 14, v8.5, AUG 01,2017, IHS/CMI/MWR
+14 ;---> IHS Forecast Addendum to TCH Report.
+15 ;----------
LDFORC(BIDFN,BIFORC,BIHX,BIFDT,BIDUZ2,BINF,BIPDSS,BIADDND) ;EP
+1 ;---> Load Immserve Data (Immunizations Due) into ^BIPDUE(.
+2 ;---> Parameters:
+3 ; 1 - BIDFN (req) Patient IEN.
+4 ; 2 - BIFORC (req) String containing Patient's Imms Due.
+5 ; 3 - BIHX (req) String containing Patient's Imm History.
+6 ; 4 - BIFDT (opt) Forecast Date (date used for forecast).
+7 ; 5 - BIDUZ2 (opt) User's DUZ(2) indicating site parameters.
+8 ; 6 - BINF (opt) Array of Vaccine Grp IEN'S that should not be forecast.
+9 ; 7 - BIPDSS (ret) Returned string of V IMM IEN's that are
+10 ; Problem Doses, according to ImmServe.
+11 ; 8 - BIADDND(ret) IHS forecasting addendum (to be added to TCH Report).
+12 ;
+13 IF '$GET(BIDFN)
QUIT
IF $GET(BIFORC)=""
QUIT
IF $GET(BIHX)=""
QUIT
+14 ;---> If no Forecast Date passed, set it equal to today.
+15 IF '$GET(BIFDT)
SET BIFDT=DT
IF '$DATA(BINF)
SET BINF=""
+16 ;
+17 ;---> First clear out any previously set Immunizations Due and
+18 ;---> any Forecasting Errors for this patient.
+19 DO KILLDUE^BIPATUP2(BIDFN)
+20 ;
+21 ;---> If no BIDUZ2, try DUZ(2); otherwise, defaults will be used.
+22 IF '$GET(BIDUZ2)
SET BIDUZ2=$GET(DUZ(2))
+23 ;
+24 ;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
+25 ;---> Check for any input doses that TCH identified as problems.
+26 ;---> Build and return a string of "V IMM IEN_%_CVX" problem doses,
+27 ;---> as identified in the TCH Input Doses segment.
+28 DO DPROBS^BIPATUP2(BIFORC,.BIPDSS)
+29 ;**********
+30 ;
+31 ;---> Seed BITCHAF to collect
+32 NEW BITCHAF
SET BITCHAF=""
+33 ;
+34 ;---> Parse Doses Due from Forecaster string (BIFORC), perform any
+35 ;---> necessary translations, and set as due in patient global ^BIPDUE(.
+36 DO DDUE(BIFORC,BIHX,.BINF,BIDUZ2,BIFDT,.BITCHAF)
+37 ;
+38 ;---> After loading (SETDUE) TCH forecast, perform any follow-up forecasting
+39 ;---> needed for High Risk, "Post-forecast".
+40 DO IHSPOST(BIDFN,BIHX,BIFDT,BIDUZ2,.BINF,BITCHAF,.BIADDND)
+41 ;
+42 QUIT
+43 ;
+44 ;
+45 ;----------
DDUE(BIFORC,BIHX,BINF,BIDUZ2,BIFDT,BITCHAF) ;EP
+1 ;---> Parse Doses Due from Immserve string (BIFORC), perform any
+2 ;---> necessary translations, and set as due in patient global ^BIPDUE.
+3 ;---> Parameters:
+4 ; 1 - BIFORC (req) Forecast string coming back from TCH.
+5 ; 2 - BIHX (req) String containing Patient's Imm History.
+6 ; 3 - BINF (opt) Array of Vaccine Grp IEN'S that should not be forecast.
+7 ; 4 - BIDUZ2 (opt) User's DUZ(2) indicating site parameters.
+8 ; 5 - BIFDT (opt) Forecast Date (date used for forecast).
+9 ; 6 - BITCHAF (ret) [1=TCH Already Forecast Pneumo (33), [2=HepB(45), [3=HepA(85).
+10 ;
+11 ;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
+12 ;---> Changes to accommodate new TCH Forecaster parsing.
+13 NEW BIFORC1,BIDOSE,N
+14 SET BIFORC1=$PIECE(BIFORC,"~~~",3)
+15 ;
+16 FOR N=1:1
SET BIDOSE=$PIECE(BIFORC1,"|||",N)
IF (BIDOSE="")
QUIT
Begin DoDot:1
+17 DO DDUE2(BIDOSE,BIHX,.BINF,.BIPC,BIDUZ2,BIFDT,.BITCHAF)
End DoDot:1
+18 QUIT
+19 ;
+20 ;
+21 ;----------
DDUE2(BIDOSE,BIHX,BINF,BIPC,BIDUZ2,BIFDT,BITCHAF) ;EP
+1 ;---> Parse Doses Due (see linelabel DDUE above).
+2 ;---> Parameters: See DDUE immediately above!
+3 ;
+4 ;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
+5 ;---> Many changes below to accommodate new TCH Forecaster.
+6 ;
+7 ;---> Uncomment next line to see raw Doses Due:
+8 ;W !!!,BIDOSE R ZZZ
+9 ;
+10 NEW A,BI,D,X
SET X=BIDOSE
+11 ;---> A=CVX Code
+12 SET A=$PIECE(X,U,1)
+13 ;
+14 ;---> "PAST"=Past Due Indicator
+15 SET BI("PAST")=$PIECE(X,U,3)
+16 ;
+17 ;---> Get Fileman formats of due dates.
+18 ;---> "MIN"=Minimum Date Due
+19 SET BI("MIN")=$$TCHFMDT^BIUTL5($PIECE(X,U,4))
IF ('BI("MIN"))
SET BI("MIN")=""
+20 ;
+21 ;---> "REC"=Recommended Date Due
+22 SET BI("REC")=$$TCHFMDT^BIUTL5($PIECE(X,U,5))
IF ('BI("REC"))
SET BI("REC")=""
+23 ;
+24 ;---> "EXC"=Exceeds Date Due
+25 SET BI("EXC")=$$TCHFMDT^BIUTL5($PIECE(X,U,6))
IF ('BI("EXC"))
SET BI("EXC")=""
+26 ;
+27 ;---> Determine whether to set Recommended Age or Minimum Accepted Age
+28 ;---> based on Site Parameter.
+29 SET BI("DUE")=BI("REC")
+30 IF $$MINAGE^BIUTL2($GET(BIDUZ2))=1
SET BI("DUE")=BI("MIN")
+31 ;
+32 ;---> If this dose is past due (BI("PAST")=1), D(2) will stuff DATE PAST DUE;
+33 ;---> Otherwise, D(1) will stuff RECOMMENDED DATE DUE.
+34 SET (D(1),D(2))=""
Begin DoDot:1
+35 IF BI("PAST")
SET D(2)=BI("EXC")
QUIT
+36 SET D(1)=BI("DUE")
End DoDot:1
+37 ;
+38 ;---> *** TRANSLATIONS OF INCOMING IMMSERVE VACCINES:
+39 ;---> -------------------------------------------
+40 IF A=""
QUIT
+41 ;
+42 ;---> Check to see if Site specified do not forecast this Vaccine Group.
+43 IF $DATA(BINF($$HL7TX^BIUTL2(A,1)))
QUIT
+44 ;
+45 ;
+46 ;********** PATCH 13, v8.5, AUG 01,2016, IHS/CMI/MWR
+47 ;---> Do not forecast Flu (CVX 88) before local Flu Season Start Date, regardless of
+48 ;---> Min vs. Rec site parameter #8.
+49 IF A=88
IF $EXTRACT($GET(BIFDT),4,5)>6
IF (BIFDT<($EXTRACT(BIFDT,1,3)_$TRANSLATE($PIECE($$FLUDATS^BIUTL8(BIDUZ2),"%"),"/")))
QUIT
+50 ;**********
+51 ;
+52 ;---> Add this Immunization Due.
+53 DO SETDUE^BIPATUP2(BIDFN_U_$$HL7TX^BIUTL2(A)_U_U_D(1)_U_D(2))
+54 ;
+55 ;********** PATCH 14, v8.5, AUG 01,2017, IHS/CMI/MWR
+56 ;---> Use BITCHAF to track TCH forecasting of Pneumo, Hep A and Hep B.
+57 ;
+58 ;---> Pneumo 33 OR 133 was forecast by TCH.
+59 IF (A=33)!(A=133)
SET BITCHAF=BITCHAF_1
+60 ;---> Hep B was forecast by TCH.
+61 IF A=45
SET BITCHAF=BITCHAF_2
+62 ;---> Hep A was forecast by TCH.
+63 IF A=85
SET BITCHAF=BITCHAF_3
+64 ;
+65 QUIT
+66 ;
+67 ;
+68 ;********** PATCH 14, v8.5, AUG 01,2017, IHS/CMI/MWR
+69 ;---> Extensive changes.
+70 ;----------
IHSPOST(BIDFN,BIHX,BIFDT,BIDUZ2,BINF,BITCHAF,BIADDND) ;EP
+1 ;---> Post forecast; after loading TCH forecast, perform any follow-up forecasting
+2 ;---> needed for High Risk.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient IEN.
+5 ; 2 - BIHX (req) String containing Patient's Imm History.
+6 ; 3 - BIFDT (req) Forecast Date (date used for forecast).
+7 ; 4 - BIDUZ2 (req) User's DUZ(2) for High Risk Site Parameter.
+8 ; 5 - BINF (opt) Array of Vaccine Grp IEN'S that should not be forecast.
+9 ; 6 - BIADDND (ret) IHS forecasting addendum (to be added to TCH Report).
+10 ;
+11 ;---> Loop through History string, gathering previous Influenzas and Pneumos.
+12 ;
+13 NEW BIDOSE,BIFLU,BIHX1,I,X,Y
+14 SET BIHX1=$PIECE(BIHX,"~~~",2)
+15 ;
+16 ;---> Loop through RPMS Input String History, collecting for prior Pneumo.
+17 ;---> Store in BIFLU by HL7 Code, inverse date.
+18 ;F I=1:1:Y D
+19 FOR I=1:1
SET BIDOSE=$PIECE(BIHX1,"|||",I)
IF BIDOSE=""
QUIT
Begin DoDot:1
+20 ;
+21 ;---> For this Immunization, set A=CVX Code, D=Date.
+22 NEW A,D
SET A=$PIECE(BIDOSE,U,2)
SET D=$PIECE(BIDOSE,U,3)
+23 ;
+24 ;---> Quit if Dose Override is Invalid (1-4).
+25 IF $PIECE(BIDOSE,U,4)
IF $PIECE(BIDOSE,U,4)<9
QUIT
+26 ;
+27 ;---> If this is Hep B or Hep A,
+28 ;---> translate and store it in local array BIFLU(CVX,Inverse Fm date).
+29 ;---> (Pneumo (33,100,109,133,152) not translated.)
+30 ;
+31 ;---> Collect Hep B CVX's.
+32 IF ((A=8)!(A=42)!(A=44)!(A=43)!(A=43)!(A=51)!(A=102))
SET A=45
+33 IF ((A=104)!(A=110)!(A=132)!(A=146))
SET A=45
+34 ;
+35 ;---> Collect Hep A CVX's.
+36 IF ((A=31)!(A=52)!(A=83)!(A=84)!(A=104)!(A=169))
SET A=85
+37 ;
+38 ;---> Save any Pneumo, Hep B, or Hep A.
+39 IF ((A=33)!(A=100)!(A=109)!(A=133)!(A=152)!(A=45)!(A=85))
Begin DoDot:2
+40 SET BIFLU(A,9999999-$$TCHFMDT^BIUTL5(D))=""
End DoDot:2
End DoDot:1
+41 ;
+42 ;
+43 ;---> Check for THIS PATIENT: forced Pneumo or Disregard all Risk Factors.
+44 ;---> BIFFLU: 0=Normal, 1=not used, 2=Force Pneumo, 3=not used, 4=Disregard Risk Factors.
+45 SET BIFFLU=$$INFL^BIUTL11(BIDFN)
+46 ;---> Quit (don't check Risk Factors) if BIFFLU=4, Disregard Risk Factors for this patient.
+47 IF BIFFLU=4
QUIT
+48 ;
+49 ;---> Quit if SITE PARAMETER says NOT to include any Risk Factors in forecast (returns 0).
+50 NEW BIRISK
SET BIRISK=$$RISKP^BIUTL2(BIDUZ2)
+51 IF 'BIRISK
QUIT
+52 ;
+53 IF '$GET(BIFDT)
SET BIFDT=$GET(DT)
+54 ;
+55 ;---> Set Patient Age in years for this Forecast Date.
+56 NEW BIAGE
SET BIAGE=$$AGE^BIUTL1(BIDFN,1,BIFDT)
+57 ;
+58 ;---> No High Risk computation under 19 years.
+59 IF (BIAGE<19)
QUIT
+60 ;
+61 ;
+62 ;---> * * * Forecast Pneumo for High Risk if needed. * * *
+63 Begin DoDot:1
+64 ;---> Quit if CVX 33 is in the history (satisfies both Early Pneumo and High Risk.)
+65 IF ($DATA(BIFLU(33)))
QUIT
+66 ;
+67 ;---> Quit if TCH already forecast Pneumo (33).
+68 IF (BITCHAF[1)
QUIT
+69 ;---> Quit if Site Parameter does not include Pneumo.
+70 IF (BIRISK'[1)
QUIT
+71 ;---> Check if Site Parameter includes Smoking (includes 9).
+72 NEW BIRISKF,BISMKR
SET BISMKR=$SELECT(BIRISK[9:1,1:0)
+73 ;---> Check for High Risk.
+74 DO RISKP^BIDX(BIDFN,BIFDT,BIAGE,BISMKR,.BIRISKF)
+75 ;
+76 ;---> Set Early Forecast or High Risk if needed.
+77 DO IHSPNEU^BIPATUP3(BIDFN,.BIFLU,BIFFLU,.BINF,BIFDT,BIAGE,BIDUZ2,BIRISKF,.BIADDND)
End DoDot:1
+78 ;
+79 ;
+80 ;---> * * * Forecast Hep B for Diabetes if needed. * * *
+81 Begin DoDot:1
+82 ;---> Quit if Hep B (45) is in the history, ever received a Hep B.
+83 IF ($DATA(BIFLU(45)))
QUIT
+84 ;---> Quit if TCH already forecast Hep B (45).
+85 IF (BITCHAF[2)
QUIT
+86 ;---> Quit if Site Parameter does not include Hep B for Diabetes.
+87 IF (BIRISK'[2)
QUIT
+88 ;---> Quit if this Pt Age is older than 60 yrs, regardless of risk.
+89 IF (BIAGE>59)
QUIT
+90 ;---> Check for High Risk.
+91 NEW BIRISKF
+92 DO RISKB^BIDX(BIDFN,BIFDT,BIAGE,.BIRISKF)
+93 IF 'BIRISKF
QUIT
+94 ;---> Set Early Forecast or High Risk if needed.
+95 DO IHSHEPB^BIPATUP3(BIDFN,.BINF,BIFDT,1,.BIADDND)
+96 SET BITCHAF=BITCHAF_2
End DoDot:1
+97 ;
+98 ;
+99 ;---> * * * Forecast Hep A & B for CLD/HepC if needed. * * *
+100 Begin DoDot:1
+101 ;---> Quit if Hep A (85) and Hep B (45) are BOTH in the history.
+102 IF ($DATA(BIFLU(85))&$DATA(BIFLU(45)))
QUIT
+103 ;---> Quit if Site Parameter does not include Hep A&B for CLD/HepC.
+104 IF (BIRISK'[3)
QUIT
+105 ;
+106 ;---> Check for High Risk.
+107 NEW BIRISKF
+108 DO RISKAB^BIDX(BIDFN,BIFDT,.BIRISKF)
+109 IF 'BIRISKF
QUIT
+110 ;
+111 ;---> If TCH did NOT already forecast Hep B (45), forecast Hep B for CLD/HepC.
+112 IF ('$DATA(BIFLU(45)))&(BITCHAF'[2)
DO IHSHEPB^BIPATUP3(BIDFN,.BINF,BIFDT,2,.BIADDND)
+113 ;
+114 ;---> If TCH did NOT already forecast Hep A (85), forecast Hep A for CLD/HepC.
+115 IF ('$DATA(BIFLU(85)))&(BITCHAF'[3)
DO IHSHEPA^BIPATUP3(BIDFN,.BINF,BIFDT,,.BIADDND)
End DoDot:1
+116 ;
+117 QUIT
