Routine: PSJIBAG

PSJIBAG ;BIR/JCH - IV PARAMETER VALIDATION ; 08/10/12 12:26pm

 ;;5.0;INPATIENT MEDICATIONS;**279,326**;16 DEC 97;Build 1

 ;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.

 ; Reference to ^PSBPOIV is supported by DBIA #5434

PSBPOIV(DFN,ORDER,PSJQT,PSJINIV) ; Check BCMA IV Parameters, invalidate labels

 ; DFN - Patient IEN

 ; ORDER - Inpatient IV order

 ; PSJQT - Quiet (no display)

 ;       - 100 = called from Label Log

 ; PSJINIV - Were any labels invalidated?

 ;           0=NO, 1=YES

 Q:'$G(DFN)!'$G(ORDER)!'($G(ORDER)["V")

 K ^TMP("PSBAR",$J),^TMP("PSJINBAG",$J,DFN,+ORDER)

 I '$G(PSJQT) W !,"Checking IV Labels..."

 D EN^PSBPOIV(DFN,ORDER)

 N INVDT,PSJAVAIL,Y,COU,PSJDOLJ D NOW^%DTC S INVDT=%,PSJAVAIL=0,PSJDOLJ=$J

 N LBLID S LBLID=0 F  S LBLID=$O(^TMP("PSBAR",$J,LBLID)) Q:'LBLID  D

 .N LBLNUM,INVBCMA S INVBCMA=$P($G(^TMP("PSBAR",$J,LBLID)),"^")

 .I (INVBCMA'="I"),'$G(PSJAVAIL) K ^TMP("PSJINBAG",$J),^TMP("PSBAR",$J,"I") S PSJAVAIL=1,INVDT=""

 .S LBLNUM=$P(LBLID,"V",2) Q:'LBLNUM

 .N INVIPM S INVIPM=$P($G(^PS(55,DFN,"IVBCMA",LBLNUM,0)),"^",9) Q:INVIPM

 .S ^TMP("PSJINBAG",$J,DFN,ORDER,LBLID)=INVDT

 I $D(^TMP("PSJINBAG",$J,DFN,ORDER)) D

 .I ($G(PSJQT)) D DATA(DFN,+ORDER,,,$G(PSJAVAIL),,1),EXIT Q

 .D VFY(DFN,ORDER,INVDT,$G(PSJAVAIL)),EXIT

VFY(DFN,PSIVON55,INVDT,PSJAVAIL) ; If AUTO-VERIFY turned off, veryifying pharmacist needs to be reminded about invalidated labels before being prompted to print labels

 N PSJIAL,PSJIACT,PSJBLN,PSJDNE,PSIVTMP,Y S PSJBLN=0,PSJDNE=0,PSJINIV="",PSJDOLJ=$J

 N BCINVF S BCINVF=$G(^TMP("PSBAR",$J,"I")) I BCINVF]"" D

 .N TMPINFLD S TMPINFLD=$P(BCINVF,"invalid",2) S TMPINFLD=$TR(TMPINFLD,".") I $E(TMPINFLD)=" " S TMPINFLD=$E(TMPINFLD,2,99)

 .S BCINVF=TMPINFLD

 I '$G(PSJAVAIL)&(BCINVF="") Q

 D FULL^VALM1

 I '$G(PSJAVAIL),($G(BCINVF)]"") W !!!?6,"**  Edit to ",BCINVF," has invalidated the following IV labels  **" D

 .W !?4,"(Invalid IV labels cannot be reprinted or marked as Infusing in BCMA)"

 I $G(PSJAVAIL) W !!!?12,"**  The following labels are available  **"

 D DATA(DFN,PSIVON55,,$S($G(PSJAVAIL):"",1:INVDT),$S($G(PSJAVAIL):PSJAVAIL,1:""),.PSJINIV)

 I '$G(PSJAVAIL) D

 .N DIR,DA S DIR(0)="SAO^P:PRINT",DIR("A")="Enter 'P' to print list of Invalidated Labels or RETURN to continue: " D ^DIR

 .I '($G(Y)="P") K ^TMP("PSJINBAG",$J) Q

 .D DEV(DFN,PSIVON55,INVDT)

 I $G(PSJAVAIL) D CONT^PSJOE0 K ^TMP("PSJINBAG",$J)

DATA(DFN,ON,PSJIPRNT,PSJIINV,PSJAVAIL,PSJINIV,PSJQT) ;Get the Information

 N PSJINVDT

EN2 ; Queued entry point

 N TMPON55,PSJBLN,PSJD1,X,DA,DR,DIQ,DIC,PSJD2,LLCNT,PSJBLNL,TMPON,PSIVSCR,PSGP

 K PSJDNE S PSIVSCR=$E(IOST)="C",COU=0,LLCNT=0

 I ($G(ON)["P") S TMPON=ON N HDR531 S HDR531=$G(^PS(53.1,+ON,0)) S HDR531=$P(HDR531,"^",25) I HDR531["V" S ON=HDR531

 S ON=+ON

 S ^TMP("PSJINBAG",PSJDOLJ,DFN,ON_"V")=$S($G(PSJAVAIL):"AVAILABLE",1:"INVALID")

 I $G(PSJIPRNT) D ENIV^PSJAC D

 .N LOC,PN,AI,ADCNT,SOLCNT S LOC=$P($G(VAIN(4)),"^",2) I LOC="" S LOC=+$G(^PS(55,DFN,"IV",+ON,"DSS")) D

 ..S LOC=$S($G(LOC):$P($G(^SC(+LOC,0)),"^"),1:"NOT FOUND")

 .S PN=$S(($G(PSGP(0))]""):PSGP(0),1:$P($G(^DPT(DFN,0)),"^"))

 .U IO W !!?23,"* Invalidated IV Labels *",!!?5,"Patient: ",PN,?50,"Location: ",LOC

 .S ADCNT=0 F AI=1:1 S ADCNT=$O(^PS(55,DFN,"IV",+ON,"AD",ADCNT)) Q:'ADCNT  D

 ..N IVND0,IVSTR S IVND0=$G(^PS(55,DFN,"IV",+ON,"AD",ADCNT,0)),IVSTR=$P(IVND0,"^",2)

 ..I AI=1 W !?1,"Additive(s) (current order): ",?14,$P($G(^PS(52.6,+IVND0,0)),"^") Q

 ..W !?14,$P($G(^PS(52.6,+IVND0,0)),"^")

 .S SOLCNT=0 F AI=1:1 S SOLCNT=$O(^PS(55,DFN,"IV",+ON,"SOL",SOLCNT)) Q:'SOLCNT  D

 ..N IVND0,IVOL S IVND0=$G(^PS(55,DFN,"IV",+ON,"SOL",SOLCNT,0)),IVOL=$P(IVND0,"^",2)

 ..I AI=1 W !?1,"Solution(s) (current order): ",?14,$P($G(^PS(52.7,+IVND0,0)),"^") Q

 ..W !?14,$P($G(^PS(52.6,+$G(^PS(55,DFN,"IV",+ON,"SOL",SOLCNT,0)),0)),"^")

 I '$G(PSJQT) U IO W ! D H2 S PSJBLN=0,LLCNT=1

 I $G(PSJIINV) D NOW^%DTC S (PSJIINV,PSJINVDT)=$S($G(PSJIINV)>200000:PSJIINV,1:%) D UPD(DFN,ON,PSJINVDT,.PSJINIV)

 I '$G(PSJQT) S ON=ON_"V" S PSJBLNL=0 F  S PSJBLNL=$O(^TMP("PSJINBAG",PSJDOLJ,DFN,ON,PSJBLNL)) Q:'PSJBLNL  D DISPLAY

K ;

 K NUMLAB,TRA,CD,DATE,DIR,DIC,%

DISPLAY ; Display or Print labels

 K DA,DR,DIQ,DIC,PSJD2 N IVALID,LBST,BCST,LSTAT,PSJBLN

 S PSJBLN=$P(PSJBLNL,"V",2)

 S DIC="^PS(55,"_DFN_",""IVBCMA"",",DA=PSJBLN,DR=".01;.02;1;2;3;4;5;9",DIQ="PSJD2",DIQ(0)="IE" D EN^DIQ1

 S BCST=$G(PSJD2(55.0105,PSJBLN,2,"E")) Q:(BCST="COMPLETED")!(BCST="GIVEN")

 Q:($G(PSJD2(55.0105,PSJBLN,5,"E"))]"")

 S IVALID=$P($G(^PS(55,DFN,"IVBCMA",+PSJBLN,0)),"^",9)

 I IVALID Q:($G(PSJIINV))&(IVALID'=$G(PSJIINV))

 I PSIVSCR,($Y#IOSL)>23 D PAUSE,H2 S LLCNT=$G(LLCNT)+3

 W $$ENDTC1^PSGMI($G(PSJD2(55.0105,PSJBLN,4,"I"))),?17,$G(PSJD2(55.0105,PSJBLN,.01,"I")) S LLCNT=$G(LLCNT)+1 I $X>39 W ! S LLCNT=$G(LLCNT)+1

 S LBST=$G(PSJD2(55.0105,PSJBLN,5,"E"))

 W ?39,LBST S LLCNT=$G(LLCNT)+1

 S X=$G(PSJD2(55.0105,PSJBLN,3,"I")) W ?51,$S(X:"YES",1:"NO")

 W ?57,$G(PSJD2(55.0105,PSJBLN,2,"E")) S LLCNT=$G(LLCNT)+1

 I $G(PSJD2(55.0105,PSJBLN,1,"I"))]"" W ?66,$$ENDTC1^PSGMI($G(PSJD2(55.0105,PSJBLN,1,"I"))) S LLCNT=$G(LLCNT)+1

 W ! S LLCNT=$G(LLCNT)

 I $G(LLCNT)>40 D PAUSE W !! S LLCNT=2

PAUSE ;

 Q:'($E(IOST)="C")

 N DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJDNE=1

H ;Header

N I

 W !!,"LABEL LOG:",!!,"#",?3,"DATE/TIME",?18,"ACTION",?32,"USER",?47,"#LABELS",?60,"TRACK",?75,"COUNT",! F I=1:1:80 W "=" W:I=80 !

H2 ;Header for Unique ID #s

 W !,"Label Date/Time",?17,"Unique ID",?39,"Status",?51,"Count",?57,"BCMA Action-Date/Time"

 W !,"---------------",?17,"--------",?39,"---------",?51,"-----",?57,"-----------------------",!

DEV(DFN,ON55,INVDT) ;Device

 K %ZIS,IOP,POP,ZTSK,IO("Q") S PSJION=$I,%ZIS="QM"

 N ZTDESC,ZTRTN,ZTSAVE,G

 D ^%ZIS K %ZIS S PSJIPRNT=1,PSJIINV=""

 I POP S IOP=PSJION S %ZIS("A")="Select DEVICE:" D ^%ZIS K IOP,PSJION W !,"Please try later!" G EXIT

 K PSJION I $D(IO("Q")) D  G EXIT

 .S ZTDESC="Invalidated IV Labels Report",ZTRTN="EN2^PSJIBAG"

 .F G="DFN","ON55","PSJIPRNT","INVDT","PSJDOLJ","ON","PSJSYSU" S:$D(@G) ZTSAVE(G)=""

 .K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print!" K ZTSK

 D EN2 W ! D PAUSE^PSJLMUT1

EXIT ;

 W ! D ^%ZISC K DIR,DTOUT,DUOUT,DIROUT,DIRUT

 K ^TMP("PSBAR",$J)

UPD(DFN,ON,PSJINVDT,PSJINIV) ; Go through labels, invalidate each

 S ON=ON_"V"

 N PSJBLN S PSJBLN=0 F  S PSJBLN=$O(^TMP("PSJINBAG",$J,DFN,ON,PSJBLN)) Q:'PSJBLN  D

 .K DA,DR,DIQ,DIC,PSJD2 N IVALID,LBST,BCST

 .S DIC="^PS(55,"_DFN_",""IVBCMA"",",DA=PSJBLN,DR=".01;.02;1;2;3;4;5",DIQ="PSJD2",DIQ(0)="IE" D EN^DIQ1

 .Q:$P($G(^PS(55,DFN,"IVBCMA",+PSJBLN,0)),"^",9)

 .S BCST=$G(PSJD2(55.0105,PSJBLN,2,"E")) Q:(BCST="COMPLETED")!(BCST="GIVEN")

 .D UP1(DFN,ON,$P(PSJBLN,"V",2),PSJINVDT,.PSJINIV)

 S ^TMP("PSJINBAG",$J,DFN,ON)=PSJINVDT

UP1(DFN,ON,PSJBLN,PSJINVDT,PSJINIV) ; invalidate one label

 ;Input:  DFN     - patient's IEN

 ;        ON      - Order number for this bar code ID

 ;        PSJBLN  - Label index number from PS(55,DFN,"IVBCMA".

 ;        PSJINVDT- Invalidation Date

 Q:'$G(PSJBLN)!'$G(DFN)!'$G(ON)

 Q:'$G(^PS(55,DFN,"IVBCMA",+PSJBLN,0))

 N PSJBCID,NOW S PSJBCID=DFN_"V"_PSJBLN

 S DA(1)=DFN,X=PSJBCID,DIC="^PS(55,"_DA(1)_",""IVBCMA"","

 K DA,DR,DIE S DIE=DIC,DA=PSJBLN,DA(1)=DFN D NOW^%DTC S NOW=$S($G(PSJINVDT):PSJINVDT,1:%)

 S DR="9////"_+PSJINVDT D ^DIE

 K DIC,DIE,D0,DA,DR

 I '$G(PSJINIV) S PSJINIV=1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJIBAG   7502     printed  Mar 13, 2025@21:12                                                                                                                                                                                                        Page 2

PSJIBAG   ;BIR/JCH - IV PARAMETER VALIDATION ; 08/10/12 12:26pm

 +1       ;;5.0;INPATIENT MEDICATIONS;**279,326**;16 DEC 97;Build 1

 +2       ;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.

 +3       ;

 +4       ; Reference to ^PSBPOIV is supported by DBIA #5434

 +5       ;

PSBPOIV(DFN,ORDER,PSJQT,PSJINIV) ; Check BCMA IV Parameters, invalidate labels

 +1       ; DFN - Patient IEN

 +2       ; ORDER - Inpatient IV order

 +3       ; PSJQT - Quiet (no display)

 +4       ;       - 100 = called from Label Log

 +5       ; PSJINIV - Were any labels invalidated?

 +6       ;           0=NO, 1=YES

 +7       ;

 +8        if '$GET(DFN)!'$GET(ORDER)!'($GET(ORDER)["V")

               QUIT

 +9        KILL ^TMP("PSBAR",$JOB),^TMP("PSJINBAG",$JOB,DFN,+ORDER)

 +10       IF '$GET(PSJQT)

               WRITE !,"Checking IV Labels..."

 +11       DO EN^PSBPOIV(DFN,ORDER)

 +12       NEW INVDT,PSJAVAIL,Y,COU,PSJDOLJ

           DO NOW^%DTC

           SET INVDT=%

           SET PSJAVAIL=0

           SET PSJDOLJ=$JOB

 +13       NEW LBLID

           SET LBLID=0

FOR

               SET LBLID=$ORDER(^TMP("PSBAR",$JOB,LBLID))

               if 'LBLID

                   QUIT

               Begin DoDot:1

 +14               NEW LBLNUM,INVBCMA

                   SET INVBCMA=$PIECE($GET(^TMP("PSBAR",$JOB,LBLID)),"^")

 +15               IF (INVBCMA'="I")

                       IF '$GET(PSJAVAIL)

                           KILL ^TMP("PSJINBAG",$JOB),^TMP("PSBAR",$JOB,"I")

                           SET PSJAVAIL=1

                           SET INVDT=""

 +16               SET LBLNUM=$PIECE(LBLID,"V",2)

                   if 'LBLNUM

                       QUIT

 +17               NEW INVIPM

                   SET INVIPM=$PIECE($GET(^PS(55,DFN,"IVBCMA",LBLNUM,0)),"^",9)

                   if INVIPM

                       QUIT

 +18               SET ^TMP("PSJINBAG",$JOB,DFN,ORDER,LBLID)=INVDT

               End DoDot:1

 +19       IF $DATA(^TMP("PSJINBAG",$JOB,DFN,ORDER))

               Begin DoDot:1

 +20               IF ($GET(PSJQT))

                       DO DATA(DFN,+ORDER,,,$GET(PSJAVAIL),,1)

                       DO EXIT

                       QUIT

 +21               DO VFY(DFN,ORDER,INVDT,$GET(PSJAVAIL))

                   DO EXIT

               End DoDot:1

 +22       QUIT

 +23      ;

VFY(DFN,PSIVON55,INVDT,PSJAVAIL) ; If AUTO-VERIFY turned off, veryifying pharmacist needs to be reminded about invalidated labels before being prompted to print labels

 +1        NEW PSJIAL,PSJIACT,PSJBLN,PSJDNE,PSIVTMP,Y

           SET PSJBLN=0

           SET PSJDNE=0

           SET PSJINIV=""

           SET PSJDOLJ=$JOB

 +2        NEW BCINVF

           SET BCINVF=$GET(^TMP("PSBAR",$JOB,"I"))

           IF BCINVF]""

               Begin DoDot:1

 +3                NEW TMPINFLD

                   SET TMPINFLD=$PIECE(BCINVF,"invalid",2)

                   SET TMPINFLD=$TRANSLATE(TMPINFLD,".")

                   IF $EXTRACT(TMPINFLD)=" "

                       SET TMPINFLD=$EXTRACT(TMPINFLD,2,99)

 +4                SET BCINVF=TMPINFLD

               End DoDot:1

 +5        IF '$GET(PSJAVAIL)&(BCINVF="")

               QUIT

 +6        DO FULL^VALM1

 +7        IF '$GET(PSJAVAIL)

               IF ($GET(BCINVF)]"")

                   WRITE !!!?6,"**  Edit to ",BCINVF," has invalidated the following IV labels  **"

                   Begin DoDot:1

 +8                    WRITE !?4,"(Invalid IV labels cannot be reprinted or marked as Infusing in BCMA)"

                   End DoDot:1

 +9        IF $GET(PSJAVAIL)

               WRITE !!!?12,"**  The following labels are available  **"

 +10       DO DATA(DFN,PSIVON55,,$SELECT($GET(PSJAVAIL):"",1:INVDT),$SELECT($GET(PSJAVAIL):PSJAVAIL,1:""),.PSJINIV)

 +11       IF '$GET(PSJAVAIL)

               Begin DoDot:1

 +12               NEW DIR,DA

                   SET DIR(0)="SAO^P:PRINT"

                   SET DIR("A")="Enter 'P' to print list of Invalidated Labels or RETURN to continue: "

                   DO ^DIR

 +13               IF '($GET(Y)="P")

                       KILL ^TMP("PSJINBAG",$JOB)

                       QUIT

 +14               DO DEV(DFN,PSIVON55,INVDT)

               End DoDot:1

 +15       IF $GET(PSJAVAIL)

               DO CONT^PSJOE0

               KILL ^TMP("PSJINBAG",$JOB)

 +16       QUIT

 +17      ;

DATA(DFN,ON,PSJIPRNT,PSJIINV,PSJAVAIL,PSJINIV,PSJQT) ;Get the Information

 +1        NEW PSJINVDT

EN2       ; Queued entry point

 +1        NEW TMPON55,PSJBLN,PSJD1,X,DA,DR,DIQ,DIC,PSJD2,LLCNT,PSJBLNL,TMPON,PSIVSCR,PSGP

 +2        KILL PSJDNE

           SET PSIVSCR=$EXTRACT(IOST)="C"

           SET COU=0

           SET LLCNT=0

 +3        IF ($GET(ON)["P")

               SET TMPON=ON

               NEW HDR531

               SET HDR531=$GET(^PS(53.1,+ON,0))

               SET HDR531=$PIECE(HDR531,"^",25)

               IF HDR531["V"

                   SET ON=HDR531

 +4        SET ON=+ON

 +5        SET ^TMP("PSJINBAG",PSJDOLJ,DFN,ON_"V")=$SELECT($GET(PSJAVAIL):"AVAILABLE",1:"INVALID")

 +6        IF $GET(PSJIPRNT)

               DO ENIV^PSJAC

               Begin DoDot:1

 +7                NEW LOC,PN,AI,ADCNT,SOLCNT

                   SET LOC=$PIECE($GET(VAIN(4)),"^",2)

                   IF LOC=""

                       SET LOC=+$GET(^PS(55,DFN,"IV",+ON,"DSS"))

                       Begin DoDot:2

 +8                        SET LOC=$SELECT($GET(LOC):$PIECE($GET(^SC(+LOC,0)),"^"),1:"NOT FOUND")

                       End DoDot:2

 +9                SET PN=$SELECT(($GET(PSGP(0))]""):PSGP(0),1:$PIECE($GET(^DPT(DFN,0)),"^"))

 +10               USE IO

                   WRITE !!?23,"* Invalidated IV Labels *",!!?5,"Patient: ",PN,?50,"Location: ",LOC

 +11               SET ADCNT=0

                   FOR AI=1:1

                       SET ADCNT=$ORDER(^PS(55,DFN,"IV",+ON,"AD",ADCNT))

                       if 'ADCNT

                           QUIT

                       Begin DoDot:2

 +12                       NEW IVND0,IVSTR

                           SET IVND0=$GET(^PS(55,DFN,"IV",+ON,"AD",ADCNT,0))

                           SET IVSTR=$PIECE(IVND0,"^",2)

 +13                       IF AI=1

                               WRITE !?1,"Additive(s) (current order): ",?14,$PIECE($GET(^PS(52.6,+IVND0,0)),"^")

                               QUIT

 +14                       WRITE !?14,$PIECE($GET(^PS(52.6,+IVND0,0)),"^")

                       End DoDot:2

 +15               SET SOLCNT=0

                   FOR AI=1:1

                       SET SOLCNT=$ORDER(^PS(55,DFN,"IV",+ON,"SOL",SOLCNT))

                       if 'SOLCNT

                           QUIT

                       Begin DoDot:2

 +16                       NEW IVND0,IVOL

                           SET IVND0=$GET(^PS(55,DFN,"IV",+ON,"SOL",SOLCNT,0))

                           SET IVOL=$PIECE(IVND0,"^",2)

 +17                       IF AI=1

                               WRITE !?1,"Solution(s) (current order): ",?14,$PIECE($GET(^PS(52.7,+IVND0,0)),"^")

                               QUIT

 +18                       WRITE !?14,$PIECE($GET(^PS(52.6,+$GET(^PS(55,DFN,"IV",+ON,"SOL",SOLCNT,0)),0)),"^")

                       End DoDot:2

               End DoDot:1

 +19       IF '$GET(PSJQT)

               USE IO

               WRITE !

               DO H2

               SET PSJBLN=0

               SET LLCNT=1

 +20       IF $GET(PSJIINV)

               DO NOW^%DTC

               SET (PSJIINV,PSJINVDT)=$SELECT($GET(PSJIINV)>200000:PSJIINV,1:%)

               DO UPD(DFN,ON,PSJINVDT,.PSJINIV)

 +21       IF '$GET(PSJQT)

               SET ON=ON_"V"

               SET PSJBLNL=0

FOR

                   SET PSJBLNL=$ORDER(^TMP("PSJINBAG",PSJDOLJ,DFN,ON,PSJBLNL))

                   if 'PSJBLNL

                       QUIT

                   DO DISPLAY

 +22      ;

K         ;

 +1        KILL NUMLAB,TRA,CD,DATE,DIR,DIC,%

 +2        QUIT

 +3       ;

DISPLAY   ; Display or Print labels

 +1        KILL DA,DR,DIQ,DIC,PSJD2

           NEW IVALID,LBST,BCST,LSTAT,PSJBLN

 +2        SET PSJBLN=$PIECE(PSJBLNL,"V",2)

 +3        SET DIC="^PS(55,"_DFN_",""IVBCMA"","

           SET DA=PSJBLN

           SET DR=".01;.02;1;2;3;4;5;9"

           SET DIQ="PSJD2"

           SET DIQ(0)="IE"

           DO EN^DIQ1

 +4        SET BCST=$GET(PSJD2(55.0105,PSJBLN,2,"E"))

           if (BCST="COMPLETED")!(BCST="GIVEN")

               QUIT

 +5        if ($GET(PSJD2(55.0105,PSJBLN,5,"E"))]"")

               QUIT

 +6        SET IVALID=$PIECE($GET(^PS(55,DFN,"IVBCMA",+PSJBLN,0)),"^",9)

 +7        IF IVALID

               if ($GET(PSJIINV))&(IVALID'=$GET(PSJIINV))

                   QUIT

 +8        IF PSIVSCR

               IF ($Y#IOSL)>23

                   DO PAUSE

                   DO H2

                   SET LLCNT=$GET(LLCNT)+3

 +9        WRITE $$ENDTC1^PSGMI($GET(PSJD2(55.0105,PSJBLN,4,"I"))),?17,$GET(PSJD2(55.0105,PSJBLN,.01,"I"))

           SET LLCNT=$GET(LLCNT)+1

           IF $X>39

               WRITE !

               SET LLCNT=$GET(LLCNT)+1

 +10       SET LBST=$GET(PSJD2(55.0105,PSJBLN,5,"E"))

 +11       WRITE ?39,LBST

           SET LLCNT=$GET(LLCNT)+1

 +12       SET X=$GET(PSJD2(55.0105,PSJBLN,3,"I"))

           WRITE ?51,$SELECT(X:"YES",1:"NO")

 +13       WRITE ?57,$GET(PSJD2(55.0105,PSJBLN,2,"E"))

           SET LLCNT=$GET(LLCNT)+1

 +14       IF $GET(PSJD2(55.0105,PSJBLN,1,"I"))]""

               WRITE ?66,$$ENDTC1^PSGMI($GET(PSJD2(55.0105,PSJBLN,1,"I")))

               SET LLCNT=$GET(LLCNT)+1

 +15       WRITE !

           SET LLCNT=$GET(LLCNT)

 +16       IF $GET(LLCNT)>40

               DO PAUSE

               WRITE !!

               SET LLCNT=2

 +17       QUIT

PAUSE     ;

 +1        if '($EXTRACT(IOST)="C")

               QUIT

 +2        NEW DIR

           SET DIR(0)="E"

           DO ^DIR

           if $DATA(DTOUT)!($DATA(DUOUT))

               SET PSJDNE=1

 +3        QUIT

H         ;Header

 +1        NEW I

 +2        WRITE !!,"LABEL LOG:",!!,"#",?3,"DATE/TIME",?18,"ACTION",?32,"USER",?47,"#LABELS",?60,"TRACK",?75,"COUNT",!

           FOR I=1:1:80

               WRITE "="

               if I=80

                   WRITE !

 +3        QUIT

H2        ;Header for Unique ID #s

 +1        WRITE !,"Label Date/Time",?17,"Unique ID",?39,"Status",?51,"Count",?57,"BCMA Action-Date/Time"

 +2        WRITE !,"---------------",?17,"--------",?39,"---------",?51,"-----",?57,"-----------------------",!

 +3        QUIT

DEV(DFN,ON55,INVDT) ;Device

 +1        KILL %ZIS,IOP,POP,ZTSK,IO("Q")

           SET PSJION=$IO

           SET %ZIS="QM"

 +2        NEW ZTDESC,ZTRTN,ZTSAVE,G

 +3        DO ^%ZIS

           KILL %ZIS

           SET PSJIPRNT=1

           SET PSJIINV=""

 +4        IF POP

               SET IOP=PSJION

               SET %ZIS("A")="Select DEVICE:"

               DO ^%ZIS

               KILL IOP,PSJION

               WRITE !,"Please try later!"

               GOTO EXIT

 +5        KILL PSJION

           IF $DATA(IO("Q"))

               Begin DoDot:1

 +6                SET ZTDESC="Invalidated IV Labels Report"

                   SET ZTRTN="EN2^PSJIBAG"

 +7                FOR G="DFN","ON55","PSJIPRNT","INVDT","PSJDOLJ","ON","PSJSYSU"

                       if $DATA(@G)

                           SET ZTSAVE(G)=""

 +8                KILL IO("Q")

                   DO ^%ZTLOAD

                   if $DATA(ZTSK)

                       WRITE !,"Report is Queued to print!"

                   KILL ZTSK

               End DoDot:1

               GOTO EXIT

 +9        DO EN2

           WRITE !

           DO PAUSE^PSJLMUT1

EXIT      ;

 +1        WRITE !

           DO ^%ZISC

           KILL DIR,DTOUT,DUOUT,DIROUT,DIRUT

 +2        KILL ^TMP("PSBAR",$JOB)

 +3        QUIT

UPD(DFN,ON,PSJINVDT,PSJINIV) ; Go through labels, invalidate each

 +1        SET ON=ON_"V"

 +2        NEW PSJBLN

           SET PSJBLN=0

FOR

               SET PSJBLN=$ORDER(^TMP("PSJINBAG",$JOB,DFN,ON,PSJBLN))

               if 'PSJBLN

                   QUIT

               Begin DoDot:1

 +3                KILL DA,DR,DIQ,DIC,PSJD2

                   NEW IVALID,LBST,BCST

 +4                SET DIC="^PS(55,"_DFN_",""IVBCMA"","

                   SET DA=PSJBLN

                   SET DR=".01;.02;1;2;3;4;5"

                   SET DIQ="PSJD2"

                   SET DIQ(0)="IE"

                   DO EN^DIQ1

 +5                if $PIECE($GET(^PS(55,DFN,"IVBCMA",+PSJBLN,0)),"^",9)

                       QUIT

 +6                SET BCST=$GET(PSJD2(55.0105,PSJBLN,2,"E"))

                   if (BCST="COMPLETED")!(BCST="GIVEN")

                       QUIT

 +7                DO UP1(DFN,ON,$PIECE(PSJBLN,"V",2),PSJINVDT,.PSJINIV)

               End DoDot:1

 +8        SET ^TMP("PSJINBAG",$JOB,DFN,ON)=PSJINVDT

 +9        QUIT

UP1(DFN,ON,PSJBLN,PSJINVDT,PSJINIV) ; invalidate one label

 +1       ;Input:  DFN     - patient's IEN

 +2       ;        ON      - Order number for this bar code ID

 +3       ;        PSJBLN  - Label index number from PS(55,DFN,"IVBCMA".

 +4       ;        PSJINVDT- Invalidation Date

 +5       ;

 +6        if '$GET(PSJBLN)!'$GET(DFN)!'$GET(ON)

               QUIT

 +7        if '$GET(^PS(55,DFN,"IVBCMA",+PSJBLN,0))

               QUIT

 +8        NEW PSJBCID,NOW

           SET PSJBCID=DFN_"V"_PSJBLN

 +9        SET DA(1)=DFN

           SET X=PSJBCID

           SET DIC="^PS(55,"_DA(1)_",""IVBCMA"","

 +10       KILL DA,DR,DIE

           SET DIE=DIC

           SET DA=PSJBLN

           SET DA(1)=DFN

           DO NOW^%DTC

           SET NOW=$SELECT($GET(PSJINVDT):PSJINVDT,1:%)

 +11       SET DR="9////"_+PSJINVDT

           DO ^DIE

 +12       KILL DIC,DIE,D0,DA,DR

 +13       IF '$GET(PSJINIV)

               SET PSJINIV=1

 +14       QUIT

PSJIBAG.m