PSIVLBL1 ;BIR/RGY-PRINT LABEL FROM WARD LIST ;24 Aug 2001 3:59 PM
;;5.0; INPATIENT MEDICATIONS ;**69,58,81,97,104**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^%DT is supported by DBIA 10003.
; Reference to ^%ZIS is supported by DBIA 10086.
; Reference to ^%ZTLOAD is supported by DBIA 10063.
; Reference to ^DICN is supported by DBIA 10009.
; Reference to ^DIR is supported by DBIA 10026.
; Reference to ^VALM1 is supported by DBIA 10116.
;
START S Y=1 W !!,"Schedule labels for DATE: TODAY//" R X:DTIME S:'$T X="^" S:X="" X="T" Q:X["^" I X'["?" S %DT="EX" D ^%DT
G:Y<1 START
I X["?" S HELP="LBL1" D ^PSIVHLP S X="?" D ^%DT G START
ASK S PSIVDT=Y\1 D ^PSIVWL1 G QUIT:'$D(PSIVOD)!('$D(PSIVCD))
I PSIVPL'=ION D QUE G QUIT
DEQ ;
L +^PS(55,"PSIVWL",PSIVSN):1 E W:$Y @IOF W !!,"**** WARNING --- LABELS NOT",!," RUN, WARD LIST IN PROGRESS" G QUIT
S PSIVT="" F PSIVLBL1=0:0 S PSIVT=$O(PSIVOD(PSIVT)) Q:PSIVT="" S WRD="" D @("LBL"_$S($D(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT))):"M",1:"W"))
I $G(PSJRPFLG) D
. W !!,"*** NOTE ***"
. W !!,"Schedule labels had already printed for the selected manufacturing time."
. W !,"Please use the Reprint Scheduled Labels option instead.",!
. K PSJRPFLG
QUIT L -^PS(55,"PSIVWL",PSIVSN) S:$D(ZTQUEUED) ZTREQ="@" K %,%DT,%T,D,DFN,I,JJ,NOFLG,ON,P,PSCT,PSIV,PSIVCD,PSIVDT,PSIVDOSE,PSIVMT,PSIVOD,PSIVNOL,PSIVT,VAERR,WRD,X,X1,X2,Y,Z,ZTSK,OIX1,OIX2
Q
LBLM ;
N OIX1,OIX2 I '$D(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT)) D DESC(PSIVT) Q
S OIX1=0 F S OIX1=$O(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1)) Q:OIX1="" S OIX2=0 F S OIX2=$O(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1,OIX2)) Q:OIX2="" D LBLM1
K JX Q
LBLM1 ;
S NOFLG=1 N DFNX,ONX
S DFNX=0 F S DFNX=$O(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1,OIX2,DFNX)) Q:'DFNX D
. S DFN=+DFNX D ENIV^PSJAC S DFN=DFNX,ONX=0 F S ONX=$O(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1,OIX2,DFN,ONX)) Q:'ONX D
.. S ON=+ONX,WRD=$P(^(+ON),"^",2),X1=OIX1,X2=OIX2 D MEOW
; naked reference on line above refers to the ^PS(55,"PSIVWLM" reference on the line preceding the naked reference
D:NOFLG DESC(PSIVT)
Q
LBLW ; loop through ward lists
N DFNX,ONX,WRDX
S NOFLG=1 S WRDX=0 F S WRDX=$O(^PS(55,"PSIVWL",PSIVSN,WRDX)) Q:WRDX="" D
. S WRD=WRDX S DFNX=0 F S DFNX=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFNX)) Q:'DFNX D
.. S DFN=+DFNX D ENIV^PSJAC S DFN=DFNX S ONX=0 F S ONX=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ONX)) Q:'ONX S ON=+ONX D MEOW
D:NOFLG DESC(PSIVT)
Q
MEOWRPT ;Reprint from man/ward list
I '$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,0)) D MEOW Q
S PSIVWMFL=1 ;this flag indicate prt/reprt from war/man list
NEW PSJID,PSIVOID,PSIVID,X,XX
F PSJID=0:0 S PSJID=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,PSJID)) Q:'PSJID D REPRT
;
; Kill old ID and set newly reprinted ID.
;
F X=0:0 S X=$O(PSIVOID(X)) Q:'X D
. K ^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,X)
F X=0:0 S X=$O(PSIVID(X)) Q:'X D
. S ^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,X)=""
K PSIVWMFL,PSIVOID,PSIVID
Q
REPRT ; Reprint labels using existing bcma ID
S PSIVOID(PSJID)=""
NEW PSJLB S XX=$G(^PS(55,DFN,"IVBCMA",PSJID,0)) Q:XX=""
F X=1:1:8 S PSJLB(X)=$P(XX,U,X)
I $S(PSJLB(4)="C":1,PSJLB(4)="G":1,PSJLB(4)="I":1,PSJLB(7)'="":1,1:0) Q
S PSIVCTD=0,PSIVCT=1,PSIVNOL=1,P(4)=$P(^PS(55,DFN,"IV",+ON,0),"^",4)
D REPRT^PSIVLBRP(DFN_"V"_PSJID)
Q
MEOW ; Print labels
S PSIVCT=1,PSIVNOL=+^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON),P16=$P(^(+ON),"^",3),PSIVDOSE=$P(^(+ON),"^",2) I '$P(^(+ON),"^",4) S $P(^(+ON),"^",4)=1 K PSIVCT
I PSIVNOL=0 K PSIVDOSE,PSIVCT,PSIVWMFL,PSIVID Q
N PSJSCH,PSJST,A,PSJOK
S PSJSCH=$P(^PS(55,DFN,"IV",+ON,0),"^",9),PSJST=$$ONE^PSJBCMA(DFN,ON,PSJSCH)
S PSJOK=1 I PSJST="O" S A=0 F S A=$O(^PS(55,DFN,"IV",+ON,"LAB",A)) Q:A="" I $P($G(^(A,0)),"^",3)=1 S PSJOK=0 Q
Q:'PSJOK
Q:"HOD"[$P(^PS(55,DFN,"IV",+ON,0),"^",17)
I $O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ON,0)) D Q
. S NOFLG=0,PSJRPFLG=1
S PSIVWMFL=1
S IONOFF="",P(4)=$P(^PS(55,DFN,"IV",+ON,0),"^",4),ACTION=1,TRACK=2 D ^PSIVLTR D ^PSIVHYPL:P(4)="H",^PSIVLABL:"APSC"[P(4)
I $D(PSIVID) S X=0 F S X=$O(PSIVID(X)) Q:'X D
. S ^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ON,X)=""
S NOFLG=0
K PSIVDOSE,PSIVCT,PSIVWMFL,PSIVID Q
;
QUE S ZTIO=PSIVPL,ZTDESC="PRINT SCHEDULED IV LABELS",ZTRTN="DEQ^PSIVLBL1",PSIVT="",ZTSAVE("PSJSYSP0")=""
F I=0:0 S PSIVT=$O(PSIVMT(PSIVT)) Q:PSIVT="" S (ZTSAVE("PSIVCD("""_PSIVT_""")"),ZTSAVE("PSIVMT("""_PSIVT_""")"),ZTSAVE("PSIVOD("""_PSIVT_""")"))=""
F X="PSIVSN","PSIVSITE","PSJSYSW0","PSJSYSU","IONOFF" S ZTSAVE(X)=""
D ^%ZTLOAD W:$D(ZTSK) !,"Queued." Q
;
ENLBLI ;Print individual labels.
D FULL^VALM1
S PSJORD=ON D ENNH^PSIVORV2(ON)
I ON'["V" W !!,$C(7),$C(7),"You may not print labels for a pending order." W ! K DIR S DIR(0)="E" D ^DIR K DIR G Q
A1 ;
I "EDP"[$P(^PS(55,DFN,"IV",+ON,0),U,17) W !,$C(7),$C(7),"WARNING, this order is not active.",!,"Continue" S %=2 D YN^DICN G:%=2!(%=-1) Q G:%=0 A1
D PAUSE^VALM1
S PSIVLBTP=1,PSJMORE=0 D EN^VALM("PSJ LM IV LABELS") G Q
LBLBEG R !!,"Number of labels to print: ",X:DTIME Q:'$T!("^"[X) S:X["?" HELP="NOL" D:X["?" ^PSIVHLP1 G:X["?" LBLBEG K:X'=+X!(X>10)!(X<1)!(X?.E1"."1N.N) X W:'$D(X) $C(7),$C(7),"??" G:'$D(X) LBLBEG S PSIVNOL=+X,PSIVCT=1
;
USAGE ;
W !,"Count as daily usage" S %=1 D YN^DICN G:%=-1 Q K:%=1 PSIVCT I %=0 S HELP="NCILBL" D ^PSIVHLP1 G USAGE
S P16=$S('$D(PSIVCT):$P(^PS(55,DFN,"IV",+ON,0),"^",16),1:0) S:'$D(PSIVCT) $P(^(0),"^",16)=P16+X
S IONOFF="",IOP=PSIVPL,%ZIS="NQ" D ^%ZIS G:POP Q I IO=IO(0),($E(IOST)="C") W !!! D DEQIA,Q D HOME^%ZIS Q
D HOME^%ZIS
W ! S ZTDTH=$H,ZTIO=PSIVPL,ZTDESC="PRINT INDIVIDUAL IV LABELS",ZTRTN="DEQIA^PSIVLBL1" F X="IONOFF","P16","PSIVAC","PSIVNOL","PSIVSN","PSIVSITE","DFN","ON","PSJSYSW0","PSJSYSU","PSJSYSP0" S ZTSAVE(X)=""
S:$D(PSIVCT) ZTSAVE("PSIVCT")="" D ^%ZTLOAD W:$D(ZTSK) !,"Queued."
Q ;K %,IONOFF,ON,ORNS,ORPV,ORSTOP,ORSTRT,ORSTS,ORVP,P,PSIVC,PSIVREA,J,N,N2,ORIFN,P17,SCHED,PSIVDOSE,PSIVNOL,PSIVNOW,VAERR
K %,IONOFF,ORNS,ORPV,ORSTOP,ORSTRT,ORSTS,ORVP,PSIVC,PSIVREA,J,N,N2,ORIFN,P17,SCHED,PSIVDOSE,PSIVNOL,PSIVNOW,VAERR
Q
DEQIA ;
K PSIVDOSE S P(4)=$P(^PS(55,DFN,"IV",+ON,0),"^",4)
S ACTION=1,TRACK=1 D ^PSIVLTR
;
D ^PSIVHYPL:P(4)="H",^PSIVLABL:"APSC"[P(4) S:$D(ZTQUEUED) ZTREQ="@"
Q
DESC(X) ;Expand the IV type.
NEW XX,Y,DESC,X1,X2 S Y=$$CODES^PSIVUTL(X,55.01,.04)
S XX="***NO "_Y_" DATA***"
NEW MARX D TXT^PSGMUTL(XX,$P(PSIVSITE,U,13))
F XX=1:1:(+PSIVSITE+$P(PSIVSITE,U,16)) W:XX>2 $G(MARX(XX-2)) W !
Q
PSIVLBL1 ;BIR/RGY-PRINT LABEL FROM WARD LIST ;24 Aug 2001 3:59 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**69,58,81,97,104**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191.
+4 ; Reference to ^%DT is supported by DBIA 10003.
+5 ; Reference to ^%ZIS is supported by DBIA 10086.
+6 ; Reference to ^%ZTLOAD is supported by DBIA 10063.
+7 ; Reference to ^DICN is supported by DBIA 10009.
+8 ; Reference to ^DIR is supported by DBIA 10026.
+9 ; Reference to ^VALM1 is supported by DBIA 10116.
+10 ;
START SET Y=1
WRITE !!,"Schedule labels for DATE: TODAY//"
READ X:DTIME
IF '$TEST
SET X="^"
IF X=""
SET X="T"
IF X["^"
QUIT
IF X'["?"
SET %DT="EX"
DO ^%DT
+1 IF Y<1
GOTO START
+2 IF X["?"
SET HELP="LBL1"
DO ^PSIVHLP
SET X="?"
DO ^%DT
GOTO START
ASK SET PSIVDT=Y\1
DO ^PSIVWL1
IF '$DATA(PSIVOD)!('$DATA(PSIVCD))
GOTO QUIT
+1 IF PSIVPL'=ION
DO QUE
GOTO QUIT
DEQ ;
+1 LOCK +^PS(55,"PSIVWL",PSIVSN):1
IF '$TEST
IF $Y
WRITE @IOF
WRITE !!,"**** WARNING --- LABELS NOT",!," RUN, WARD LIST IN PROGRESS"
GOTO QUIT
+2 SET PSIVT=""
FOR PSIVLBL1=0:0
SET PSIVT=$ORDER(PSIVOD(PSIVT))
IF PSIVT=""
QUIT
SET WRD=""
DO @("LBL"_$SELECT($DATA(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT))):"M",1:"W"))
+3 IF $GET(PSJRPFLG)
Begin DoDot:1
+4 WRITE !!,"*** NOTE ***"
+5 WRITE !!,"Schedule labels had already printed for the selected manufacturing time."
+6 WRITE !,"Please use the Reprint Scheduled Labels option instead.",!
+7 KILL PSJRPFLG
End DoDot:1
QUIT LOCK -^PS(55,"PSIVWL",PSIVSN)
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL %,%DT,%T,D,DFN,I,JJ,NOFLG,ON,P,PSCT,PSIV,PSIVCD,PSIVDT,PSIVDOSE,PSIVMT,PSIVOD,PSIVNOL,PSIVT,VAERR,WRD,X,X1,X2,Y,Z,ZTSK,OIX1,OIX2
+1 QUIT
LBLM ;
+1 NEW OIX1,OIX2
IF '$DATA(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT))
DO DESC(PSIVT)
QUIT
+2 SET OIX1=0
FOR
SET OIX1=$ORDER(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1))
IF OIX1=""
QUIT
SET OIX2=0
FOR
SET OIX2=$ORDER(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1,OIX2))
IF OIX2=""
QUIT
DO LBLM1
+3 KILL JX
QUIT
LBLM1 ;
+1 SET NOFLG=1
NEW DFNX,ONX
+2 SET DFNX=0
FOR
SET DFNX=$ORDER(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1,OIX2,DFNX))
IF 'DFNX
QUIT
Begin DoDot:1
+3 SET DFN=+DFNX
DO ENIV^PSJAC
SET DFN=DFNX
SET ONX=0
FOR
SET ONX=$ORDER(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1,OIX2,DFN,ONX))
IF 'ONX
QUIT
Begin DoDot:2
+4 SET ON=+ONX
SET WRD=$PIECE(^(+ON),"^",2)
SET X1=OIX1
SET X2=OIX2
DO MEOW
End DoDot:2
End DoDot:1
+5 ; naked reference on line above refers to the ^PS(55,"PSIVWLM" reference on the line preceding the naked reference
+6 IF NOFLG
DO DESC(PSIVT)
+7 QUIT
LBLW ; loop through ward lists
+1 NEW DFNX,ONX,WRDX
+2 SET NOFLG=1
SET WRDX=0
FOR
SET WRDX=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRDX))
IF WRDX=""
QUIT
Begin DoDot:1
+3 SET WRD=WRDX
SET DFNX=0
FOR
SET DFNX=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFNX))
IF 'DFNX
QUIT
Begin DoDot:2
+4 SET DFN=+DFNX
DO ENIV^PSJAC
SET DFN=DFNX
SET ONX=0
FOR
SET ONX=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ONX))
IF 'ONX
QUIT
SET ON=+ONX
DO MEOW
End DoDot:2
End DoDot:1
+5 IF NOFLG
DO DESC(PSIVT)
+6 QUIT
MEOWRPT ;Reprint from man/ward list
+1 IF '$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,0))
DO MEOW
QUIT
+2 ;this flag indicate prt/reprt from war/man list
SET PSIVWMFL=1
+3 NEW PSJID,PSIVOID,PSIVID,X,XX
+4 FOR PSJID=0:0
SET PSJID=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,PSJID))
IF 'PSJID
QUIT
DO REPRT
+5 ;
+6 ; Kill old ID and set newly reprinted ID.
+7 ;
+8 FOR X=0:0
SET X=$ORDER(PSIVOID(X))
IF 'X
QUIT
Begin DoDot:1
+9 KILL ^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,X)
End DoDot:1
+10 FOR X=0:0
SET X=$ORDER(PSIVID(X))
IF 'X
QUIT
Begin DoDot:1
+11 SET ^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,X)=""
End DoDot:1
+12 KILL PSIVWMFL,PSIVOID,PSIVID
+13 QUIT
REPRT ; Reprint labels using existing bcma ID
+1 SET PSIVOID(PSJID)=""
+2 NEW PSJLB
SET XX=$GET(^PS(55,DFN,"IVBCMA",PSJID,0))
IF XX=""
QUIT
+3 FOR X=1:1:8
SET PSJLB(X)=$PIECE(XX,U,X)
+4 IF $SELECT(PSJLB(4)="C":1,PSJLB(4)="G":1,PSJLB(4)="I":1,PSJLB(7)'="":1,1:0)
QUIT
+5 SET PSIVCTD=0
SET PSIVCT=1
SET PSIVNOL=1
SET P(4)=$PIECE(^PS(55,DFN,"IV",+ON,0),"^",4)
+6 DO REPRT^PSIVLBRP(DFN_"V"_PSJID)
+7 QUIT
MEOW ; Print labels
+1 SET PSIVCT=1
SET PSIVNOL=+^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON)
SET P16=$PIECE(^(+ON),"^",3)
SET PSIVDOSE=$PIECE(^(+ON),"^",2)
IF '$PIECE(^(+ON),"^",4)
SET $PIECE(^(+ON),"^",4)=1
KILL PSIVCT
+2 IF PSIVNOL=0
KILL PSIVDOSE,PSIVCT,PSIVWMFL,PSIVID
QUIT
+3 NEW PSJSCH,PSJST,A,PSJOK
+4 SET PSJSCH=$PIECE(^PS(55,DFN,"IV",+ON,0),"^",9)
SET PSJST=$$ONE^PSJBCMA(DFN,ON,PSJSCH)
+5 SET PSJOK=1
IF PSJST="O"
SET A=0
FOR
SET A=$ORDER(^PS(55,DFN,"IV",+ON,"LAB",A))
IF A=""
QUIT
IF $PIECE($GET(^(A,0)),"^",3)=1
SET PSJOK=0
QUIT
+6 IF 'PSJOK
QUIT
+7 IF "HOD"[$PIECE(^PS(55,DFN,"IV",+ON,0),"^",17)
QUIT
+8 IF $ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ON,0))
Begin DoDot:1
+9 SET NOFLG=0
SET PSJRPFLG=1
End DoDot:1
QUIT
+10 SET PSIVWMFL=1
+11 SET IONOFF=""
SET P(4)=$PIECE(^PS(55,DFN,"IV",+ON,0),"^",4)
SET ACTION=1
SET TRACK=2
DO ^PSIVLTR
IF P(4)="H"
DO ^PSIVHYPL
IF "APSC"[P(4)
DO ^PSIVLABL
+12 IF $DATA(PSIVID)
SET X=0
FOR
SET X=$ORDER(PSIVID(X))
IF 'X
QUIT
Begin DoDot:1
+13 SET ^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ON,X)=""
End DoDot:1
+14 SET NOFLG=0
+15 KILL PSIVDOSE,PSIVCT,PSIVWMFL,PSIVID
QUIT
+16 ;
QUE SET ZTIO=PSIVPL
SET ZTDESC="PRINT SCHEDULED IV LABELS"
SET ZTRTN="DEQ^PSIVLBL1"
SET PSIVT=""
SET ZTSAVE("PSJSYSP0")=""
+1 FOR I=0:0
SET PSIVT=$ORDER(PSIVMT(PSIVT))
IF PSIVT=""
QUIT
SET (ZTSAVE("PSIVCD("""_PSIVT_""")"),ZTSAVE("PSIVMT("""_PSIVT_""")"),ZTSAVE("PSIVOD("""_PSIVT_""")"))=""
+2 FOR X="PSIVSN","PSIVSITE","PSJSYSW0","PSJSYSU","IONOFF"
SET ZTSAVE(X)=""
+3 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"Queued."
QUIT
+4 ;
ENLBLI ;Print individual labels.
+1 DO FULL^VALM1
+2 SET PSJORD=ON
DO ENNH^PSIVORV2(ON)
+3 IF ON'["V"
WRITE !!,$CHAR(7),$CHAR(7),"You may not print labels for a pending order."
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
GOTO Q
A1 ;
+1 IF "EDP"[$PIECE(^PS(55,DFN,"IV",+ON,0),U,17)
WRITE !,$CHAR(7),$CHAR(7),"WARNING, this order is not active.",!,"Continue"
SET %=2
DO YN^DICN
IF %=2!(%=-1)
GOTO Q
IF %=0
GOTO A1
+2 DO PAUSE^VALM1
+3 SET PSIVLBTP=1
SET PSJMORE=0
DO EN^VALM("PSJ LM IV LABELS")
GOTO Q
LBLBEG READ !!,"Number of labels to print: ",X:DTIME
IF '$TEST!("^"[X)
QUIT
IF X["?"
SET HELP="NOL"
IF X["?"
DO ^PSIVHLP1
IF X["?"
GOTO LBLBEG
IF X'=+X!(X>10)!(X<1)!(X?.E1"."1N.N)
KILL X
IF '$DATA(X)
WRITE $CHAR(7),$CHAR(7),"??"
IF '$DATA(X)
GOTO LBLBEG
SET PSIVNOL=+X
SET PSIVCT=1
+1 ;
USAGE ;
+1 WRITE !,"Count as daily usage"
SET %=1
DO YN^DICN
IF %=-1
GOTO Q
IF %=1
KILL PSIVCT
IF %=0
SET HELP="NCILBL"
DO ^PSIVHLP1
GOTO USAGE
+2 SET P16=$SELECT('$DATA(PSIVCT):$PIECE(^PS(55,DFN,"IV",+ON,0),"^",16),1:0)
IF '$DATA(PSIVCT)
SET $PIECE(^(0),"^",16)=P16+X
+3 SET IONOFF=""
SET IOP=PSIVPL
SET %ZIS="NQ"
DO ^%ZIS
IF POP
GOTO Q
IF IO=IO(0)
IF ($EXTRACT(IOST)="C")
WRITE !!!
DO DEQIA
DO Q
DO HOME^%ZIS
QUIT
+4 DO HOME^%ZIS
+5 WRITE !
SET ZTDTH=$HOROLOG
SET ZTIO=PSIVPL
SET ZTDESC="PRINT INDIVIDUAL IV LABELS"
SET ZTRTN="DEQIA^PSIVLBL1"
FOR X="IONOFF","P16","PSIVAC","PSIVNOL","PSIVSN","PSIVSITE","DFN","ON","PSJSYSW0","PSJSYSU","PSJSYSP0"
SET ZTSAVE(X)=""
+6 IF $DATA(PSIVCT)
SET ZTSAVE("PSIVCT")=""
DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"Queued."
Q ;K %,IONOFF,ON,ORNS,ORPV,ORSTOP,ORSTRT,ORSTS,ORVP,P,PSIVC,PSIVREA,J,N,N2,ORIFN,P17,SCHED,PSIVDOSE,PSIVNOL,PSIVNOW,VAERR
+1 KILL %,IONOFF,ORNS,ORPV,ORSTOP,ORSTRT,ORSTS,ORVP,PSIVC,PSIVREA,J,N,N2,ORIFN,P17,SCHED,PSIVDOSE,PSIVNOL,PSIVNOW,VAERR
+2 QUIT
DEQIA ;
+1 KILL PSIVDOSE
SET P(4)=$PIECE(^PS(55,DFN,"IV",+ON,0),"^",4)
+2 SET ACTION=1
SET TRACK=1
DO ^PSIVLTR
+3 ;
+4 IF P(4)="H"
DO ^PSIVHYPL
IF "APSC"[P(4)
DO ^PSIVLABL
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
DESC(X) ;Expand the IV type.
+1 NEW XX,Y,DESC,X1,X2
SET Y=$$CODES^PSIVUTL(X,55.01,.04)
+2 SET XX="***NO "_Y_" DATA***"
+3 NEW MARX
DO TXT^PSGMUTL(XX,$PIECE(PSIVSITE,U,13))
+4 FOR XX=1:1:(+PSIVSITE+$PIECE(PSIVSITE,U,16))
IF XX>2
WRITE $GET(MARX(XX-2))
WRITE !
+5 QUIT
