BIPATUP2.m

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