BIPATUP2 ;IHS/CMI/MWR - UPDATE PATIENT DATA 2; OCT 15, 2010
;;8.5;IMMUNIZATION;**13**;AUG 01,2016
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; IHS FORECAST. UPDATE PATIENT DATA, IMM FORECAST IN ^BIPDUE(.
;; NOTE!: An earlier version of this routine is saved in BIZPATUP2.
;; PATCH 8: Changes for Problem Doses retrieval from TCH Forecaster. DPROBS+10
;; PATCH 9: Mods to flag only problem components of combo vaccines. DPROBS+23
;; PATCH 10: Strip TCH's leading zero, so it matches RPMS CVX. DPROBS+32
;; PATCH 13: Changes to...aDD "C" xref on Vaccine IEN in ^BIPDUE SETDUE+24, KILLDUE+20
;
;----------
DPROBS(BIFORC,BIPDSS,BIID) ;EP
;---> Check for any Input Doses that have Dose Problems.
;---> If any exist, build the string BIPDSS, concatenating the
;---> Visit IEN's with U.
;---> Parameters:
; 1 - BIFORC (req) Forecast string coming back from TCH.
; 2 - BIPDSS (ret) Returned string of V IMM IEN's that are Problem Doses.
; according to ImmServe.
; 3 - BIID (ret) NO LONGER USED. Immserve "Number of Input Doses" (Field 109 in 2010).
;
;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
;---> Changes to accommodate new TCH Forecaster.
;
S BIPDSS=""
;
;---> NOTE: Pulling History from the TCH Output String (NOT RPMS Input string).
N BIFORC1,BIDOSE,N
S BIFORC1=$P(BIFORC,"~~~",2)
;
F N=1:1 S BIDOSE=$P(BIFORC1,"|||",N) Q:(BIDOSE="") D
.;---> If this Input Dose was TCH-invalid (pc6), set V Imm IEN_%_CVX in
.;---> Problem Doses string (BIPDSS).
.;
.;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
.;---> Mods to flag only problem components of combo vaccines.
.;
.;---> Quit if this is not a problem dose.
.Q:('$P(BIDOSE,U,6))
.;
.N BICVXS S BICVXS=$P(BIDOSE,U,7)
.;---> If piece 7 is null then not a combo, set BIPDSS and quit.
.;
.;********** PATCH 10, v8.5, MAY 30,2015, IHS/CMI/MWR
.;---> Strip TCH's leading zero, so it matches RPMS CVX ("03"=3).
.;I 'BICVXS S BIPDSS=BIPDSS_$P(BIDOSE,U)_"%"_$P(BIDOSE,U,2)_U Q
.I 'BICVXS S BIPDSS=BIPDSS_$P(BIDOSE,U)_"%"_+$P(BIDOSE,U,2)_U Q
.;**********
.;
.;--> Piece 7 equals one or more problem CVX's in this combo, delimited by comma.
.N J F J=1:1 S BICVX=$P(BICVXS,",",J) Q:'BICVX D
..S BIPDSS=BIPDSS_$P(BIDOSE,U)_"%"_BICVX_U
.;**********
;
;W !,BIPDSS R ZZZ
Q
;
;
;----------
KILLDUE(BIDFN) ;EP
;---> Clear out any previously set Immunizations Due and
;---> any Forecasting Errors for this patient.
;---> Hardcoded to improve performance during massive reports.
;---> Parameters:
; 1 - BIDFN (req) Patient IEN.
;
Q:'BIDFN
;
;---> Clear previous Immunizations Due.
D:$D(^BIPDUE("B",BIDFN))
.N N S N=0
.F S N=$O(^BIPDUE("B",BIDFN,N)) Q:'N D
..N Y,Z S Y=$G(^BIPDUE(N,0))
..K ^BIPDUE(N),^BIPDUE("B",BIDFN,N)
..Q:Y=""
..S Z=$P(Y,U,4) K:Z ^BIPDUE("D",Z,N)
..S Z=$P(Y,U,5) K:Z ^BIPDUE("D",Z,N)
..S $P(^BIPDUE(0),U,4)=$P(^BIPDUE(0),U,4)-1
..;
..;********** PATCH 13, v8.5, AUG 01,2016, IHS/CMI/MWR
..;---> Kill "C" xref on 2nd pc, Vaccine IEN.
..S Z=$P(Y,U,2) K:Z ^BIPDUE("C",Z,N)
..;**********
..;
.K ^BIPDUE("B",BIDFN),^BIPDUE("E",BIDFN)
;
;
;---> Clear previous Forecasting Errors.
D:$D(^BIPERR("B",BIDFN))
.N N S N=0
.F S N=$O(^BIPERR("B",BIDFN,N)) Q:'N D
..K ^BIPERR("B",BIDFN,N),^BIPERR(N)
..S $P(^BIPERR(0),U,4)=$P(^BIPERR(0),U,4)-1
.K ^BIPERR("B",BIDFN)
Q
;
;
;----------
IMMSDT(DATE) ;EP
;---> Convert Immserve Date (format MMDDYYYY) TO FILEMAN
;---> Internal format.
;---> NOTE: This code is copied from routine ^BIUTL5 for speed.
;---> Any changes here should also be made to ^BIUTL5 too.
Q:'$G(DATE) "NO DATE"
Q ($E(DATE,5,9)-1700)_$E(DATE,1,2)_$E(DATE,3,4)
;
;
;----------
PNMAGE(BISITE) ;EP - Return Age Appropriate in years for Pneumo at this site.
;---> Parameters:
; 1 - BISITE (req) User's DUZ(2)
;
Q:'$G(BISITE) "65"
N Y
S Y=$P($G(^BISITE(BISITE,0)),U,10) S:'Y Y=65
Q Y
;---> q6-years no longer used.
;Q:'$G(BISITE) "65^0"
;N Y,Z
;S Y=$P($G(^BISITE(BISITE,0)),U,10) S:'Y Y=65
;S Z=$P($G(^BISITE(BISITE,0)),U,22) S:'Z Z=0
;Q Y_U_Z
Q
;
;
;----------
FLUALL(BISITE) ;EP - Return 1 to forecast Flu for ALL ages.
;---> Parameters:
; 1 - BISITE (req) User's DUZ(2)
;
Q:'$G(BISITE) 1
N Y S Y=$P($G(^BISITE(BISITE,0)),U,27)
Q:(Y=0) 0
Q 1
;
;
;----------
ZOSTER(BISITE) ;EP - Return 1 if Zostervax should be forecast.
;---> Parameters:
; 1 - BISITE (req) User's DUZ(2)
;
Q:'$G(BISITE) 1
N Y S Y=$P($G(^BISITE(BISITE,0)),U,29)
Q:(Y=0) 0
Q 1
;
;
;----------
SETDUE(BIDATA) ;EP
;---> Code to add this Immunization Due to BI PATIENT IMM DUE File #9002084.1.
;---> Hardcoded to improve performance during massive reports.
;---> Parameters:
; 1 - BIDATA (req) Data string (5 fields) for 0-node.
; BIDFN^Vaccine IEN^Dose#^Recommended Date^Date Past Due
;
Q:$G(BIDATA)=""
N A,B,BIDFN,M,N
S M=^BIPDUE(0),N=$P(M,U,3),M=$P(M,U,4) S:'N N=1
F Q:'$D(^BIPDUE(N)) S N=N+1
S BIDFN=$P(BIDATA,U) Q:'BIDFN
S ^BIPDUE(N,0)=BIDATA
;
;********** PATCH 1, v8.3.1, Dec 30,2008, IHS/CMI/MWR
;---> Add 6th pc, Date Forecast Calculated.
S:$G(DT) $P(^BIPDUE(N,0),U,6)=DT
;**********
;
S ^BIPDUE("B",BIDFN,N)=""
S A=$P(BIDATA,U,4),B=$P(BIDATA,U,5)
I A S ^BIPDUE("D",A,N)=""
I B S ^BIPDUE("D",B,N)="",^BIPDUE("E",BIDFN,B,N)=""
;
;********** PATCH 13, v8.5, AUG 01,2016, IHS/CMI/MWR
;---> Add "C" xref on 2nd pc, Vaccine IEN.
N V S V=$P(BIDATA,U,2)
I V S ^BIPDUE("C",V,N)=""
;**********
;
S $P(^BIPDUE(0),U,3,4)=N_U_(M+1)
Q
BIPATUP2 ;IHS/CMI/MWR - UPDATE PATIENT DATA 2; OCT 15, 2010
+1 ;;8.5;IMMUNIZATION;**13**;AUG 01,2016
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; IHS FORECAST. UPDATE PATIENT DATA, IMM FORECAST IN ^BIPDUE(.
+4 ;; NOTE!: An earlier version of this routine is saved in BIZPATUP2.
+5 ;; PATCH 8: Changes for Problem Doses retrieval from TCH Forecaster. DPROBS+10
+6 ;; PATCH 9: Mods to flag only problem components of combo vaccines. DPROBS+23
+7 ;; PATCH 10: Strip TCH's leading zero, so it matches RPMS CVX. DPROBS+32
+8 ;; PATCH 13: Changes to...aDD "C" xref on Vaccine IEN in ^BIPDUE SETDUE+24, KILLDUE+20
+9 ;
+10 ;----------
DPROBS(BIFORC,BIPDSS,BIID) ;EP
+1 ;---> Check for any Input Doses that have Dose Problems.
+2 ;---> If any exist, build the string BIPDSS, concatenating the
+3 ;---> Visit IEN's with U.
+4 ;---> Parameters:
+5 ; 1 - BIFORC (req) Forecast string coming back from TCH.
+6 ; 2 - BIPDSS (ret) Returned string of V IMM IEN's that are Problem Doses.
+7 ; according to ImmServe.
+8 ; 3 - BIID (ret) NO LONGER USED. Immserve "Number of Input Doses" (Field 109 in 2010).
+9 ;
+10 ;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
+11 ;---> Changes to accommodate new TCH Forecaster.
+12 ;
+13 SET BIPDSS=""
+14 ;
+15 ;---> NOTE: Pulling History from the TCH Output String (NOT RPMS Input string).
+16 NEW BIFORC1,BIDOSE,N
+17 SET BIFORC1=$PIECE(BIFORC,"~~~",2)
+18 ;
+19 FOR N=1:1
SET BIDOSE=$PIECE(BIFORC1,"|||",N)
IF (BIDOSE="")
QUIT
Begin DoDot:1
+20 ;---> If this Input Dose was TCH-invalid (pc6), set V Imm IEN_%_CVX in
+21 ;---> Problem Doses string (BIPDSS).
+22 ;
+23 ;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
+24 ;---> Mods to flag only problem components of combo vaccines.
+25 ;
+26 ;---> Quit if this is not a problem dose.
+27 IF ('$PIECE(BIDOSE,U,6))
QUIT
+28 ;
+29 NEW BICVXS
SET BICVXS=$PIECE(BIDOSE,U,7)
+30 ;---> If piece 7 is null then not a combo, set BIPDSS and quit.
+31 ;
+32 ;********** PATCH 10, v8.5, MAY 30,2015, IHS/CMI/MWR
+33 ;---> Strip TCH's leading zero, so it matches RPMS CVX ("03"=3).
+34 ;I 'BICVXS S BIPDSS=BIPDSS_$P(BIDOSE,U)_"%"_$P(BIDOSE,U,2)_U Q
+35 IF 'BICVXS
SET BIPDSS=BIPDSS_$PIECE(BIDOSE,U)_"%"_+$PIECE(BIDOSE,U,2)_U
QUIT
+36 ;**********
+37 ;
+38 ;--> Piece 7 equals one or more problem CVX's in this combo, delimited by comma.
+39 NEW J
FOR J=1:1
SET BICVX=$PIECE(BICVXS,",",J)
IF 'BICVX
QUIT
Begin DoDot:2
+40 SET BIPDSS=BIPDSS_$PIECE(BIDOSE,U)_"%"_BICVX_U
End DoDot:2
+41 ;**********
End DoDot:1
+42 ;
+43 ;W !,BIPDSS R ZZZ
+44 QUIT
+45 ;
+46 ;
+47 ;----------
KILLDUE(BIDFN) ;EP
+1 ;---> Clear out any previously set Immunizations Due and
+2 ;---> any Forecasting Errors for this patient.
+3 ;---> Hardcoded to improve performance during massive reports.
+4 ;---> Parameters:
+5 ; 1 - BIDFN (req) Patient IEN.
+6 ;
+7 IF 'BIDFN
QUIT
+8 ;
+9 ;---> Clear previous Immunizations Due.
+10 IF $DATA(^BIPDUE("B",BIDFN))
Begin DoDot:1
+11 NEW N
SET N=0
+12 FOR
SET N=$ORDER(^BIPDUE("B",BIDFN,N))
IF 'N
QUIT
Begin DoDot:2
+13 NEW Y,Z
SET Y=$GET(^BIPDUE(N,0))
+14 KILL ^BIPDUE(N),^BIPDUE("B",BIDFN,N)
+15 IF Y=""
QUIT
+16 SET Z=$PIECE(Y,U,4)
IF Z
KILL ^BIPDUE("D",Z,N)
+17 SET Z=$PIECE(Y,U,5)
IF Z
KILL ^BIPDUE("D",Z,N)
+18 SET $PIECE(^BIPDUE(0),U,4)=$PIECE(^BIPDUE(0),U,4)-1
+19 ;
+20 ;********** PATCH 13, v8.5, AUG 01,2016, IHS/CMI/MWR
+21 ;---> Kill "C" xref on 2nd pc, Vaccine IEN.
+22 SET Z=$PIECE(Y,U,2)
IF Z
KILL ^BIPDUE("C",Z,N)
+23 ;**********
+24 ;
End DoDot:2
+25 KILL ^BIPDUE("B",BIDFN),^BIPDUE("E",BIDFN)
End DoDot:1
+26 ;
+27 ;
+28 ;---> Clear previous Forecasting Errors.
+29 IF $DATA(^BIPERR("B",BIDFN))
Begin DoDot:1
+30 NEW N
SET N=0
+31 FOR
SET N=$ORDER(^BIPERR("B",BIDFN,N))
IF 'N
QUIT
Begin DoDot:2
+32 KILL ^BIPERR("B",BIDFN,N),^BIPERR(N)
+33 SET $PIECE(^BIPERR(0),U,4)=$PIECE(^BIPERR(0),U,4)-1
End DoDot:2
+34 KILL ^BIPERR("B",BIDFN)
End DoDot:1
+35 QUIT
+36 ;
+37 ;
+38 ;----------
IMMSDT(DATE) ;EP
+1 ;---> Convert Immserve Date (format MMDDYYYY) TO FILEMAN
+2 ;---> Internal format.
+3 ;---> NOTE: This code is copied from routine ^BIUTL5 for speed.
+4 ;---> Any changes here should also be made to ^BIUTL5 too.
+5 IF '$GET(DATE)
QUIT "NO DATE"
+6 QUIT ($EXTRACT(DATE,5,9)-1700)_$EXTRACT(DATE,1,2)_$EXTRACT(DATE,3,4)
+7 ;
+8 ;
+9 ;----------
PNMAGE(BISITE) ;EP - Return Age Appropriate in years for Pneumo at this site.
+1 ;---> Parameters:
+2 ; 1 - BISITE (req) User's DUZ(2)
+3 ;
+4 IF '$GET(BISITE)
QUIT "65"
+5 NEW Y
+6 SET Y=$PIECE($GET(^BISITE(BISITE,0)),U,10)
IF 'Y
SET Y=65
+7 QUIT Y
+8 ;---> q6-years no longer used.
+9 ;Q:'$G(BISITE) "65^0"
+10 ;N Y,Z
+11 ;S Y=$P($G(^BISITE(BISITE,0)),U,10) S:'Y Y=65
+12 ;S Z=$P($G(^BISITE(BISITE,0)),U,22) S:'Z Z=0
+13 ;Q Y_U_Z
+14 QUIT
+15 ;
+16 ;
+17 ;----------
FLUALL(BISITE) ;EP - Return 1 to forecast Flu for ALL ages.
+1 ;---> Parameters:
+2 ; 1 - BISITE (req) User's DUZ(2)
+3 ;
+4 IF '$GET(BISITE)
QUIT 1
+5 NEW Y
SET Y=$PIECE($GET(^BISITE(BISITE,0)),U,27)
+6 IF (Y=0)
QUIT 0
+7 QUIT 1
+8 ;
+9 ;
+10 ;----------
ZOSTER(BISITE) ;EP - Return 1 if Zostervax should be forecast.
+1 ;---> Parameters:
+2 ; 1 - BISITE (req) User's DUZ(2)
+3 ;
+4 IF '$GET(BISITE)
QUIT 1
+5 NEW Y
SET Y=$PIECE($GET(^BISITE(BISITE,0)),U,29)
+6 IF (Y=0)
QUIT 0
+7 QUIT 1
+8 ;
+9 ;
+10 ;----------
SETDUE(BIDATA) ;EP
+1 ;---> Code to add this Immunization Due to BI PATIENT IMM DUE File #9002084.1.
+2 ;---> Hardcoded to improve performance during massive reports.
+3 ;---> Parameters:
+4 ; 1 - BIDATA (req) Data string (5 fields) for 0-node.
+5 ; BIDFN^Vaccine IEN^Dose#^Recommended Date^Date Past Due
+6 ;
+7 IF $GET(BIDATA)=""
QUIT
+8 NEW A,B,BIDFN,M,N
+9 SET M=^BIPDUE(0)
SET N=$PIECE(M,U,3)
SET M=$PIECE(M,U,4)
IF 'N
SET N=1
+10 FOR
IF '$DATA(^BIPDUE(N))
QUIT
SET N=N+1
+11 SET BIDFN=$PIECE(BIDATA,U)
IF 'BIDFN
QUIT
+12 SET ^BIPDUE(N,0)=BIDATA
+13 ;
+14 ;********** PATCH 1, v8.3.1, Dec 30,2008, IHS/CMI/MWR
+15 ;---> Add 6th pc, Date Forecast Calculated.
+16 IF $GET(DT)
SET $PIECE(^BIPDUE(N,0),U,6)=DT
+17 ;**********
+18 ;
+19 SET ^BIPDUE("B",BIDFN,N)=""
+20 SET A=$PIECE(BIDATA,U,4)
SET B=$PIECE(BIDATA,U,5)
+21 IF A
SET ^BIPDUE("D",A,N)=""
+22 IF B
SET ^BIPDUE("D",B,N)=""
SET ^BIPDUE("E",BIDFN,B,N)=""
+23 ;
+24 ;********** PATCH 13, v8.5, AUG 01,2016, IHS/CMI/MWR
+25 ;---> Add "C" xref on 2nd pc, Vaccine IEN.
+26 NEW V
SET V=$PIECE(BIDATA,U,2)
+27 IF V
SET ^BIPDUE("C",V,N)=""
+28 ;**********
+29 ;
+30 SET $PIECE(^BIPDUE(0),U,3,4)=N_U_(M+1)
+31 QUIT
