Routine: PSIVLBL1

PSIVLBL1 ;BIR/RGY-PRINT LABEL FROM WARD LIST ;24 Aug 2001  3:59 PM

 ;;5.0;INPATIENT MEDICATIONS;**69,58,81,97,104,279**;16 DEC 97;Build 150

 ; 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

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)

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)

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

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:9 S PSJLB(X)=$P(XX,U,X)

 I $S(PSJLB(4)="C":1,PSJLB(4)="G":1,PSJLB(4)="I":1,PSJLB(7)'="":1,PSJLB(9):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)

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

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="@"

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 !

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVLBL1   6809     printed  Feb 18, 2025@23:30:44                                                                                                                                                                                                    Page 2

PSIVLBL1  ;BIR/RGY-PRINT LABEL FROM WARD LIST ;24 Aug 2001  3:59 PM

 +1       ;;5.0;INPATIENT MEDICATIONS;**69,58,81,97,104,279**;16 DEC 97;Build 150

 +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:9

               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,PSJLB(9):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

PSIVLBL1.m