PSGL0 ;BIR/CML3-ACTUAL LABEL PRINT ; 26 Jun 98 / 8:30 AM
;;5.0; INPATIENT MEDICATIONS ;**7**;16 DEC 97
ENACL ;
W !!,"There are unprinted new labels from AUTO ",$S(PSGTOL=3:"REINSTATED",1:"DISCONTINUED")," orders." F W !,"Do you want any of them now" S %=1 D YN^DICN Q:% D CHKM^PSGLH
Q:%<0 I %=1 D ENAC S %=1 Q
F W !!,"Will you want these labels at a later date" S %=1 D YN^DICN Q:% D LM^PSGLH
Q:%'=2 S DIK="^PS(53.41,",DA=PSGTOL D ^DIK S %=2 Q
;
ENAC ; select ward
W !!,"Wards: " S NP="",QQ=0 F W=1:1 S QQ=$O(^PS(53.41,PSGTOL,1,QQ)) Q:'QQ D NP:'(W#20) Q:NP["^" W !,$J(W,3),". ",$S($D(^DIC(42,QQ,0)):$P(^(0),"^"),1:QQ) S W(W)=QQ
S W=W-1 I 'W K ^PS(53.41,PSGTOL) W !!?3,"Sorry, no labels were found after all. (The problem has been corrected.)",! Q
F W !!,"Select 1 - ",W,": " R X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D SC Q:$D(X)
G:"^"[X DONE S PSGLWARD=PSGODDD F Q=1:1:PSGODDD F Q1=1:1 S Q2=$P(PSGODDD(Q),",",Q1) Q:'Q2 S PSGLWARD(Q)=$S($D(PSGLWARD(Q)):PSGLWARD(Q)_",",1:"")_W(Q2)
K ZTSAVE S PSGLRTN="ENACP^PSGL0",PSGLDESC="MAR AUTO LABELS",(ZTSAVE("PSGLWARD"),ZTSAVE("PSGLWARD("),ZTSAVE("PSGTOL"))="" D DEV1 I 'POP,'$D(IO("Q")) D ENACP
G DONE
;
ENNL ; new labels, other than auto discontinue
K ZTSAVE S PSGLRTN="ENNLP^PSGL0",PSGLDESC="UD NEW LABEL REPRINT" D DEV1 G:POP!$D(IO("Q")) DONE D ENNLP
;
SC ; selection validation
I X?1."?" W !!," Select (1-",W,") the ward(s) you wish to print labels for. Enter an '^',",!,"or press the RETURN key, to quit now." K X Q
Q:'$D(W)
S PSGLMT=W D ^PSGON W:'$D(X) $C(7)," ??" Q
;
DEV1 ; device ask for auto discontinue or new labels
K IO("Q"),%ZIS,IOP S PSGION=ION,%ZIS="Q",%ZIS("A")="Label Printing Device: ",%ZIS("B")=$P(PSJSYSL,"^",2) W ! D ^%ZIS K %ZIS I POP S IOP=PSGION D ^%ZIS K IOP S POP=1 W !,"No device selected. Option terminated." Q
D EN2^PSGLBA S POP=0 I $D(IO("Q")) S PSGTIR=PSGLRTN,ZTDESC=PSGLDESC,(ZTSAVE("PSGLWARD"),ZTSAVE("PSGLWARD("),ZTSAVE("PSGTOL"))="" W ! D ENTSK^PSGTI K PSGLDESC,PSGLRTN W:$D(ZTSK) !?3,"Labels queued!"
Q
;
ENACP ; auto label print
D NOW^%DTC S PSGDT=% U IO
F PSGLWC=1:1:PSGLWARD F PSGLWC1=1:1:$L(PSGLWARD(PSGLWC),",") S PSGLWD=$P(PSGLWARD(PSGLWC),",",PSGLWC1),PSGLWDN=$S($D(^DIC(42,PSGLWD,0)):$P(^(0),"^"),1:"zz") F PSGOP=0:0 S PSGOP=$O(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP)) Q:'PSGOP D AC
Q
AC ;
N PSJFIRST,VAINDT S PSJFIRST=1
F PSGLWC2=1,2,3 F PSGLWC3=0:0 S PSGLWC3=$O(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP,1,PSGLWC2,1,PSGLWC3)) Q:'PSGLWC3 S PSGORD=PSGLWC3_$E("ANV",PSGLWC2) D
.S:PSGTOL'=2 VAINDT=$E($P($G(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP,1,PSGLWC2,1,PSGLWC3,0)),U,3),1,12) D ^PSGLPI
.I PSJFIRST D ENHEDER^PSGLPI S PSJFIRST=0
.I PSGLWC2=2,($P($G(^PS(53.1,+PSGORD,0)),U,9)="P") S PSGORD=+PSGORD_"P" NEW PSJFLUID S:$P(^(0),U,4)="F" PSJFLUID=1
.I PSGLWC2=3!$G(PSJFLUID) D EN^PSIVUDL(PSGOP,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB)
.D:PSGLWC2'=3 ^PSGLOI
K DA,DIK S DA(1)=PSGTOL,DA=PSGLWD,DIK="^PS(53.41,"_PSGTOL_",1," D ^DIK
I '$O(^PS(53.41,PSGTOL,1,0)) K DA,DIK S DA=PSGTOL,DIK="^PS(53.41," D ^DIK
Q
;
DEV2 ; device for new labels
K IO("Q"),%ZIS,IOP S PSGION=ION,%ZIS("A")="Print on DEVICE: ",%ZIS="Q",%ZIS("B")=$P(PSJSYSL,"^",2) W ! D ^%ZIS K %ZIS I POP S IOP=PSGION D ^%ZIS K IOP S POP=1 W !,"No device selected. Option terminated." Q
I $D(IO("Q")) S PSGTIR="ENNLP^PSGL0",ZTDESC="LABELS" K ZTSAVE D ENTSK^PSGTI W:$D(ZTSK) !,"Labels queued!" Q
;
ENNLP ; new label print
D NOW^%DTC N PSJFIRST,PSJFLUID
S PSJFIRST=1,PSGDT=%,QT=2,QL=DUZ,PSJACNWP=1 U IO
F PSGOP=0:0 S PSGOP=$O(^PS(53.41,2,1,DUZ,1,PSGOP)) Q:'PSGOP D ^PSGLPI F QS=1,2,3 F QO=0:0 S QO=$O(^PS(53.41,2,1,DUZ,1,PSGOP,1,QS,1,QO)) Q:'QO D
. I PSJFIRST,$P($G(^PS(59.6,+$O(^PS(59.6,"B",+PSGLWD,0)),0)),U,18) D ENHEDER^PSGLPI S PSJFIRST=0
. S PSGORD=QO_$E("ANV",QS) I QS=2 S X=^PS(53.1,+PSGORD,0),PSJFLUID=$P(X,U,4)="F"
. I QS<3,'$G(PSJFLUID) D ^PSGLOI
. I QS=3!$G(PSJFLUID) D EN^PSIVUDL(PSGOP,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB)
K DA,DIK S DA(1)=2,DA=DUZ,DIK="^PS(53.41,2,1," D ^DIK I '$O(^PS(53.41,2,1,0)) K DA,DIK S DA=2,DIK="^PS(53.41," D ^DIK
Q
NP ;
R !!,"Enter an '^' to stop list, or press RETURN to continue. ",NP:DTIME W:'$T $C(7) S:'$T NP="^" W:NP'["^" *13,# Q
;
DONE ;
K NP,PSGOP,PSGION,QD,QS,SAVE,W,X1,X2,Z,ZTOUT D ^%ZISC
Q
;
ENKL ;
K ^PS(53.41,QT,1,QL,1,PSGOP,1,QS,1,QO)
ENKL1 Q:$O(^PS(53.41,QT,1,QL,1,PSGOP,1,QS,1,0)) K ^PS(53.41,QT,1,QL,1,PSGOP,1,QS) Q:$O(^PS(53.41,QT,1,QL,1,PSGOP,1,0)) K ^PS(53.41,QT,1,QL,1,PSGOP) Q:$O(^PS(53.41,QT,1,QL,1,0)) K ^PS(53.41,QT,1,QL)
Q
;
ENCU ; clean-up
F QT=1,2 F QL=0:0 S QL=$O(^PS(53.41,QT,1,QL)) Q:'QL F PSGOP=0:0 S PSGOP=$O(^PS(53.41,QT,1,QL,1,PSGOP)) Q:'PSGOP F QS=1,2 D ENKL1
K PSGOP,QL,QS,QT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGL0 4720 printed Nov 22, 2024@17:11:27 Page 2
PSGL0 ;BIR/CML3-ACTUAL LABEL PRINT ; 26 Jun 98 / 8:30 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**7**;16 DEC 97
ENACL ;
+1 WRITE !!,"There are unprinted new labels from AUTO ",$SELECT(PSGTOL=3:"REINSTATED",1:"DISCONTINUED")," orders."
FOR
WRITE !,"Do you want any of them now"
SET %=1
DO YN^DICN
if %
QUIT
DO CHKM^PSGLH
+2 if %<0
QUIT
IF %=1
DO ENAC
SET %=1
QUIT
+3 FOR
WRITE !!,"Will you want these labels at a later date"
SET %=1
DO YN^DICN
if %
QUIT
DO LM^PSGLH
+4 if %'=2
QUIT
SET DIK="^PS(53.41,"
SET DA=PSGTOL
DO ^DIK
SET %=2
QUIT
+5 ;
ENAC ; select ward
+1 WRITE !!,"Wards: "
SET NP=""
SET QQ=0
FOR W=1:1
SET QQ=$ORDER(^PS(53.41,PSGTOL,1,QQ))
if 'QQ
QUIT
if '(W#20)
DO NP
if NP["^"
QUIT
WRITE !,$JUSTIFY(W,3),". ",$SELECT($DATA(^DIC(42,QQ,0)):$PIECE(^(0),"^"),1:QQ)
SET W(W)=QQ
+2 SET W=W-1
IF 'W
KILL ^PS(53.41,PSGTOL)
WRITE !!?3,"Sorry, no labels were found after all. (The problem has been corrected.)",!
QUIT
+3 FOR
WRITE !!,"Select 1 - ",W,": "
READ X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if "^"[X
QUIT
DO SC
if $DATA(X)
QUIT
+4 if "^"[X
GOTO DONE
SET PSGLWARD=PSGODDD
FOR Q=1:1:PSGODDD
FOR Q1=1:1
SET Q2=$PIECE(PSGODDD(Q),",",Q1)
if 'Q2
QUIT
SET PSGLWARD(Q)=$SELECT($DATA(PSGLWARD(Q)):PSGLWARD(Q)_",",1:"")_W(Q2)
+5 KILL ZTSAVE
SET PSGLRTN="ENACP^PSGL0"
SET PSGLDESC="MAR AUTO LABELS"
SET (ZTSAVE("PSGLWARD"),ZTSAVE("PSGLWARD("),ZTSAVE("PSGTOL"))=""
DO DEV1
IF 'POP
IF '$DATA(IO("Q"))
DO ENACP
+6 GOTO DONE
+7 ;
ENNL ; new labels, other than auto discontinue
+1 KILL ZTSAVE
SET PSGLRTN="ENNLP^PSGL0"
SET PSGLDESC="UD NEW LABEL REPRINT"
DO DEV1
if POP!$DATA(IO("Q"))
GOTO DONE
DO ENNLP
+2 ;
SC ; selection validation
+1 IF X?1."?"
WRITE !!," Select (1-",W,") the ward(s) you wish to print labels for. Enter an '^',",!,"or press the RETURN key, to quit now."
KILL X
QUIT
+2 if '$DATA(W)
QUIT
+3 SET PSGLMT=W
DO ^PSGON
if '$DATA(X)
WRITE $CHAR(7)," ??"
QUIT
+4 ;
DEV1 ; device ask for auto discontinue or new labels
+1 KILL IO("Q"),%ZIS,IOP
SET PSGION=ION
SET %ZIS="Q"
SET %ZIS("A")="Label Printing Device: "
SET %ZIS("B")=$PIECE(PSJSYSL,"^",2)
WRITE !
DO ^%ZIS
KILL %ZIS
IF POP
SET IOP=PSGION
DO ^%ZIS
KILL IOP
SET POP=1
WRITE !,"No device selected. Option terminated."
QUIT
+2 DO EN2^PSGLBA
SET POP=0
IF $DATA(IO("Q"))
SET PSGTIR=PSGLRTN
SET ZTDESC=PSGLDESC
SET (ZTSAVE("PSGLWARD"),ZTSAVE("PSGLWARD("),ZTSAVE("PSGTOL"))=""
WRITE !
DO ENTSK^PSGTI
KILL PSGLDESC,PSGLRTN
if $DATA(ZTSK)
WRITE !?3,"Labels queued!"
+3 QUIT
+4 ;
ENACP ; auto label print
+1 DO NOW^%DTC
SET PSGDT=%
USE IO
+2 FOR PSGLWC=1:1:PSGLWARD
FOR PSGLWC1=1:1:$LENGTH(PSGLWARD(PSGLWC),",")
SET PSGLWD=$PIECE(PSGLWARD(PSGLWC),",",PSGLWC1)
SET PSGLWDN=$SELECT($DATA(^DIC(42,PSGLWD,0)):$PIECE(^(0),"^"),1:"zz")
FOR PSGOP=0:0
SET PSGOP=$ORDER(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP))
if 'PSGOP
QUIT
DO AC
+3 QUIT
AC ;
+1 NEW PSJFIRST,VAINDT
SET PSJFIRST=1
+2 FOR PSGLWC2=1,2,3
FOR PSGLWC3=0:0
SET PSGLWC3=$ORDER(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP,1,PSGLWC2,1,PSGLWC3))
if 'PSGLWC3
QUIT
SET PSGORD=PSGLWC3_$EXTRACT("ANV",PSGLWC2)
Begin DoDot:1
+3 if PSGTOL'=2
SET VAINDT=$EXTRACT($PIECE($GET(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP,1,PSGLWC2,1,PSGLWC3,0)),U,3),1,12)
DO ^PSGLPI
+4 IF PSJFIRST
DO ENHEDER^PSGLPI
SET PSJFIRST=0
+5 IF PSGLWC2=2
IF ($PIECE($GET(^PS(53.1,+PSGORD,0)),U,9)="P")
SET PSGORD=+PSGORD_"P"
NEW PSJFLUID
if $PIECE(^(0),U,4)="F"
SET PSJFLUID=1
+6 IF PSGLWC2=3!$GET(PSJFLUID)
DO EN^PSIVUDL(PSGOP,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB)
+7 if PSGLWC2'=3
DO ^PSGLOI
End DoDot:1
+8 KILL DA,DIK
SET DA(1)=PSGTOL
SET DA=PSGLWD
SET DIK="^PS(53.41,"_PSGTOL_",1,"
DO ^DIK
+9 IF '$ORDER(^PS(53.41,PSGTOL,1,0))
KILL DA,DIK
SET DA=PSGTOL
SET DIK="^PS(53.41,"
DO ^DIK
+10 QUIT
+11 ;
DEV2 ; device for new labels
+1 KILL IO("Q"),%ZIS,IOP
SET PSGION=ION
SET %ZIS("A")="Print on DEVICE: "
SET %ZIS="Q"
SET %ZIS("B")=$PIECE(PSJSYSL,"^",2)
WRITE !
DO ^%ZIS
KILL %ZIS
IF POP
SET IOP=PSGION
DO ^%ZIS
KILL IOP
SET POP=1
WRITE !,"No device selected. Option terminated."
QUIT
+2 IF $DATA(IO("Q"))
SET PSGTIR="ENNLP^PSGL0"
SET ZTDESC="LABELS"
KILL ZTSAVE
DO ENTSK^PSGTI
if $DATA(ZTSK)
WRITE !,"Labels queued!"
QUIT
+3 ;
ENNLP ; new label print
+1 DO NOW^%DTC
NEW PSJFIRST,PSJFLUID
+2 SET PSJFIRST=1
SET PSGDT=%
SET QT=2
SET QL=DUZ
SET PSJACNWP=1
USE IO
+3 FOR PSGOP=0:0
SET PSGOP=$ORDER(^PS(53.41,2,1,DUZ,1,PSGOP))
if 'PSGOP
QUIT
DO ^PSGLPI
FOR QS=1,2,3
FOR QO=0:0
SET QO=$ORDER(^PS(53.41,2,1,DUZ,1,PSGOP,1,QS,1,QO))
if 'QO
QUIT
Begin DoDot:1
+4 IF PSJFIRST
IF $PIECE($GET(^PS(59.6,+$ORDER(^PS(59.6,"B",+PSGLWD,0)),0)),U,18)
DO ENHEDER^PSGLPI
SET PSJFIRST=0
+5 SET PSGORD=QO_$EXTRACT("ANV",QS)
IF QS=2
SET X=^PS(53.1,+PSGORD,0)
SET PSJFLUID=$PIECE(X,U,4)="F"
+6 IF QS<3
IF '$GET(PSJFLUID)
DO ^PSGLOI
+7 IF QS=3!$GET(PSJFLUID)
DO EN^PSIVUDL(PSGOP,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB)
End DoDot:1
+8 KILL DA,DIK
SET DA(1)=2
SET DA=DUZ
SET DIK="^PS(53.41,2,1,"
DO ^DIK
IF '$ORDER(^PS(53.41,2,1,0))
KILL DA,DIK
SET DA=2
SET DIK="^PS(53.41,"
DO ^DIK
+9 QUIT
NP ;
+1 READ !!,"Enter an '^' to stop list, or press RETURN to continue. ",NP:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET NP="^"
if NP'["^"
WRITE *13,#
QUIT
+2 ;
DONE ;
+1 KILL NP,PSGOP,PSGION,QD,QS,SAVE,W,X1,X2,Z,ZTOUT
DO ^%ZISC
+2 QUIT
+3 ;
ENKL ;
+1 KILL ^PS(53.41,QT,1,QL,1,PSGOP,1,QS,1,QO)
ENKL1 if $ORDER(^PS(53.41,QT,1,QL,1,PSGOP,1,QS,1,0))
QUIT
KILL ^PS(53.41,QT,1,QL,1,PSGOP,1,QS)
if $ORDER(^PS(53.41,QT,1,QL,1,PSGOP,1,0))
QUIT
KILL ^PS(53.41,QT,1,QL,1,PSGOP)
if $ORDER(^PS(53.41,QT,1,QL,1,0))
QUIT
KILL ^PS(53.41,QT,1,QL)
+1 QUIT
+2 ;
ENCU ; clean-up
+1 FOR QT=1,2
FOR QL=0:0
SET QL=$ORDER(^PS(53.41,QT,1,QL))
if 'QL
QUIT
FOR PSGOP=0:0
SET PSGOP=$ORDER(^PS(53.41,QT,1,QL,1,PSGOP))
if 'PSGOP
QUIT
FOR QS=1,2
DO ENKL1
+2 KILL PSGOP,QL,QS,QT
QUIT
