PSIVSUS1 ;BIR/RGY-REPRINT LABEL FROM SUSPENSE ;24 JAN 94 / 11:37 AM
;;5.0;INPATIENT MEDICATIONS;**58,407**;16 DEC 97;Build 26
;
; Reference to ^PS(55 is supported by DBIA 2191.
;
D ^PSIVXU I $D(XQUIT) K XQUIT Q
Q:$G(DONE) ;P407
BEG S Y=1,BAT="@",PSIVRPNT=1 F I=1:1 S BAT=$O(^PS(55,"PSIVSUS",PSIVSN,BAT)) Q:BAT="" W !?5,I,") Labels printed on: " S Y=$E(BAT,2,999) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) S Y=BAT
I Y W !!,"*** There are no labels to reprint ! ***" G Q
ASK S X="Reprint batch #^"_(I-1)_"^^^QUX=+QUX" D ENQ^PSIV G:"^"[X Q I X["?" S HELP="RNTBAT" D ^PSIVHLP1 G ASK
S PSIVDT=+X\1,X="A" F Y=1:1 S X=$O(^PS(55,"PSIVSUS",PSIVSN,X)) Q:X=""!(Y=PSIVDT)
I X="" W $C(7)," ???" G ASK
OV S PSIVDT=X S Y=$E(X,2,999) X ^DD("DD") W " Labels printed on ",$P(Y,"@")," ",$P(Y,"@",2)
I PSIVPL'=ION S ZTIO=PSIVPL,ZTDESC="REPRINT LABELS FROM SUSPENSE (IV)",ZTRTN="DQLBL^PSIVSUS1" D QSET G Q
DQLBL F DFN=0:0 S DFN=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN)) Q:'DFN D ENIV^PSJAC F ON=0:0 S ON=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON)) Q:'ON F SDT=0:0 S SDT=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT)) Q:'SDT D LA
Q K BAT,PSIVDOSE,PSIVDT,PSIVNOL,PSIVRPNT,SDT,Z
Q1 D ENIVKV^PSGSETU S:$D(ZTQUEUED) ZTREQ="@"
Q
LA Q:"PDH"[$P($G(^PS(55,DFN,"IV",ON,0)),"^",17)
;S PSIVNOL=^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT),PSIVDOSE=$P(PSIVNOL,"^",2),PSIVCT=1,ACTION=1,TRACK=3,P16=$P(PSIVNOL,"^",3),PSIVNOL=+PSIVNOL,P(4)=$P(^PS(55,DFN,"IV",ON,0),"^",4) D ^PSIVLTR D ^PSIVHYPL:P(4)="H",^PSIVLABL:"APSC"[P(4) Q
S PSIVNOL=^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT),PSIVDOSE=$P(PSIVNOL,"^",2),PSIVCT=1,ACTION=1,TRACK=3,P16=$P(PSIVNOL,"^",3),PSIVNOL=+PSIVNOL,P(4)=$P(^PS(55,DFN,"IV",ON,0),"^",4)
D ^PSIVLTR
S PSIVWMFL=1
NEW PSJID,PSIVOID,PSIVID,X,XX
F PSJID=0:0 S PSJID=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,PSJID)) Q:'PSJID D REPRT^PSIVLBL1
;
;Kill old ID and set newly reprinted ID.
;
F X=0:0 S X=$O(PSIVOID(X)) Q:'X D
. K ^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,X)
F X=0:0 S X=$O(PSIVID(X)) Q:'X D
. S ^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,X)=""
K PSIVWMFL,PSIVOID,PSIVID
Q
ENT ;Will print man. list for suspense
D ^PSIVXU I $D(PSIVXU) K PSIVXU Q
Q:$G(DONE) ;P407
I PSIVPR'=ION K ZTDTH S ZTIO=PSIVPR,ZTDESC="PRINT MANUFACTURING LIST FOR SUSPENSE (IV)",ZTRTN="DQENT^PSIVSUS1" D QSET G QENT
DQENT K ^PS(55,"PSIVSUSM",PSIVSN,$J),PSIVOD,PSIVCD,PSIVMT S PSIVGL1="PSIVSUSM",PSIVGL2=$J
F DFN=0:0 S DFN=$O(^PS(55,"PSIVSUS",PSIVSN,DFN)) Q:'DFN D ENIV^PSJAC,RGY
D ENT^PSIVMAN1
QENT W:'$D(PSIVPR)&($Y) @IOF K ^PS(55,"PSIVSUSM",PSIVSN,$J),D,DA,DFN,I,JJ,JJ1,ON,P,PSIVGL1,PSIVGL2,PSIVTTM,SDT,TOTAL,VAERR,X,Y,Z,Z1,Z2 D Q1
Q
RGY F ON=0:0 S ON=$O(^PS(55,"PSIVSUS",PSIVSN,DFN,ON)) Q:'ON D SETP I "EOPHD"'[P(17) F SDT=0:0 S SDT=$O(^PS(55,"PSIVSUS",PSIVSN,DFN,ON,SDT)) Q:'SDT S PSIVTTM=+^(SDT) D ENS^PSIVMAN
Q
SETP S Y=$G(^PS(55,DFN,"IV",ON,0)) F X=1:1:23 S P(X)=$P(Y,"^",X)
Q
;
QSET ; Set up for queueing.
F X="PSIVSN","PSIVDT","PSIVSITE","PSJSYSW0","PSJSYSP0","PSJSYSU" S:$D(@X) ZTSAVE(X)=""
D ^%ZTLOAD W:$D(ZTSK) !,"Queued."
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVSUS1 3096 printed Dec 13, 2024@02:05:08 Page 2
PSIVSUS1 ;BIR/RGY-REPRINT LABEL FROM SUSPENSE ;24 JAN 94 / 11:37 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**58,407**;16 DEC 97;Build 26
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191.
+4 ;
+5 DO ^PSIVXU
IF $DATA(XQUIT)
KILL XQUIT
QUIT
+6 ;P407
if $GET(DONE)
QUIT
BEG SET Y=1
SET BAT="@"
SET PSIVRPNT=1
FOR I=1:1
SET BAT=$ORDER(^PS(55,"PSIVSUS",PSIVSN,BAT))
if BAT=""
QUIT
WRITE !?5,I,") Labels printed on: "
SET Y=$EXTRACT(BAT,2,999)
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2)
SET Y=BAT
+1 IF Y
WRITE !!,"*** There are no labels to reprint ! ***"
GOTO Q
ASK SET X="Reprint batch #^"_(I-1)_"^^^QUX=+QUX"
DO ENQ^PSIV
if "^"[X
GOTO Q
IF X["?"
SET HELP="RNTBAT"
DO ^PSIVHLP1
GOTO ASK
+1 SET PSIVDT=+X\1
SET X="A"
FOR Y=1:1
SET X=$ORDER(^PS(55,"PSIVSUS",PSIVSN,X))
if X=""!(Y=PSIVDT)
QUIT
+2 IF X=""
WRITE $CHAR(7)," ???"
GOTO ASK
OV SET PSIVDT=X
SET Y=$EXTRACT(X,2,999)
XECUTE ^DD("DD")
WRITE " Labels printed on ",$PIECE(Y,"@")," ",$PIECE(Y,"@",2)
+1 IF PSIVPL'=ION
SET ZTIO=PSIVPL
SET ZTDESC="REPRINT LABELS FROM SUSPENSE (IV)"
SET ZTRTN="DQLBL^PSIVSUS1"
DO QSET
GOTO Q
DQLBL FOR DFN=0:0
SET DFN=$ORDER(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN))
if 'DFN
QUIT
DO ENIV^PSJAC
FOR ON=0:0
SET ON=$ORDER(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON))
if 'ON
QUIT
FOR SDT=0:0
SET SDT=$ORDER(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT))
if 'SDT
QUIT
DO LA
Q KILL BAT,PSIVDOSE,PSIVDT,PSIVNOL,PSIVRPNT,SDT,Z
Q1 DO ENIVKV^PSGSETU
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 QUIT
LA if "PDH"[$PIECE($GET(^PS(55,DFN,"IV",ON,0)),"^",17)
QUIT
+1 ;S PSIVNOL=^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT),PSIVDOSE=$P(PSIVNOL,"^",2),PSIVCT=1,ACTION=1,TRACK=3,P16=$P(PSIVNOL,"^",3),PSIVNOL=+PSIVNOL,P(4)=$P(^PS(55,DFN,"IV",ON,0),"^",4) D ^PSIVLTR D ^PSIVHYPL:P(4)="H",^PSIVLABL:"APSC"[P(4) Q
+2 SET PSIVNOL=^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT)
SET PSIVDOSE=$PIECE(PSIVNOL,"^",2)
SET PSIVCT=1
SET ACTION=1
SET TRACK=3
SET P16=$PIECE(PSIVNOL,"^",3)
SET PSIVNOL=+PSIVNOL
SET P(4)=$PIECE(^PS(55,DFN,"IV",ON,0),"^",4)
+3 DO ^PSIVLTR
+4 SET PSIVWMFL=1
+5 NEW PSJID,PSIVOID,PSIVID,X,XX
+6 FOR PSJID=0:0
SET PSJID=$ORDER(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,PSJID))
if 'PSJID
QUIT
DO REPRT^PSIVLBL1
+7 ;
+8 ;Kill old ID and set newly reprinted ID.
+9 ;
+10 FOR X=0:0
SET X=$ORDER(PSIVOID(X))
if 'X
QUIT
Begin DoDot:1
+11 KILL ^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,X)
End DoDot:1
+12 FOR X=0:0
SET X=$ORDER(PSIVID(X))
if 'X
QUIT
Begin DoDot:1
+13 SET ^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,X)=""
End DoDot:1
+14 KILL PSIVWMFL,PSIVOID,PSIVID
+15 QUIT
ENT ;Will print man. list for suspense
+1 DO ^PSIVXU
IF $DATA(PSIVXU)
KILL PSIVXU
QUIT
+2 ;P407
if $GET(DONE)
QUIT
+3 IF PSIVPR'=ION
KILL ZTDTH
SET ZTIO=PSIVPR
SET ZTDESC="PRINT MANUFACTURING LIST FOR SUSPENSE (IV)"
SET ZTRTN="DQENT^PSIVSUS1"
DO QSET
GOTO QENT
DQENT KILL ^PS(55,"PSIVSUSM",PSIVSN,$JOB),PSIVOD,PSIVCD,PSIVMT
SET PSIVGL1="PSIVSUSM"
SET PSIVGL2=$JOB
+1 FOR DFN=0:0
SET DFN=$ORDER(^PS(55,"PSIVSUS",PSIVSN,DFN))
if 'DFN
QUIT
DO ENIV^PSJAC
DO RGY
+2 DO ENT^PSIVMAN1
QENT if '$DATA(PSIVPR)&($Y)
WRITE @IOF
KILL ^PS(55,"PSIVSUSM",PSIVSN,$JOB),D,DA,DFN,I,JJ,JJ1,ON,P,PSIVGL1,PSIVGL2,PSIVTTM,SDT,TOTAL,VAERR,X,Y,Z,Z1,Z2
DO Q1
+1 QUIT
RGY FOR ON=0:0
SET ON=$ORDER(^PS(55,"PSIVSUS",PSIVSN,DFN,ON))
if 'ON
QUIT
DO SETP
IF "EOPHD"'[P(17)
FOR SDT=0:0
SET SDT=$ORDER(^PS(55,"PSIVSUS",PSIVSN,DFN,ON,SDT))
if 'SDT
QUIT
SET PSIVTTM=+^(SDT)
DO ENS^PSIVMAN
+1 QUIT
SETP SET Y=$GET(^PS(55,DFN,"IV",ON,0))
FOR X=1:1:23
SET P(X)=$PIECE(Y,"^",X)
+1 QUIT
+2 ;
QSET ; Set up for queueing.
+1 FOR X="PSIVSN","PSIVDT","PSIVSITE","PSJSYSW0","PSJSYSP0","PSJSYSU"
if $DATA(@X)
SET ZTSAVE(X)=""
+2 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued."
