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
Q
;
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)
Q
;
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,%
Q
;
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
Q
PAUSE ;
Q:'($E(IOST)="C")
N DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJDNE=1
Q
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 !
Q
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,"-----------------------",!
Q
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)
Q
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
Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJIBAG 7502 printed Nov 22, 2024@17:17:13 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
