PSXLBL ;BIR/HTW,BAB-CMOP Host Label Print..User Input ; [ 05/01/97 11:47 AM ]
;;2.0;CMOP;**1**;11 Apr 97
START ;
L +^PSX(553):1 I '$T D MSG Q
I ^PSX(553,1,"S")="R" D MSG Q
G:'$D(^PSX(554,"AB")) SS
S R554=$O(^PSX(554,"AB",""))
I $P($G(^PSX(554,1,1,R554,0)),"^",4)="R" S ZH="F" D MSG Q
SS I ^PSX(553,1,"S")="S" S ^PSX(553,1,"P")="R"
L -^PSX(553)
SS1 W @IOF,!
SS2 S DIC=552.1,DIC(0)="AEQMZ",DIC("A")="Print Facility-Batch #: "
I $G(REPRINT) S DIC("S")="I $P(^(0),U,2)=""3""",PSXREF="AP" G ENTER
I $G(REJECT) S DIC("S")="I $P(^(0),U,2)'=""2""",PSXREF="AR" G ENTER
S DIC("S")="I $P(^(0),U,2)=""2""",PSXREF="AQ"
ENTER D ^DIC K DIC I $D(DUOUT)!($D(DTOUT))!(""[X)!(X["^") G END
S BATREF=($P(Y,U,2)),N514=+Y K X,Y,DIC
I $D(^PSX(552.1,"APR",BATREF)) W !!,"BATCH "_BATREF_" is currently being printed.",!,"Please select another batch or ""^"" to exit.",!! K N514,X,Y,DIC G SS2
I $G(REPRINT) D K J,N G CHECK
.S N="",(J,PSXBEG,PSXEND)=0
.F S N=$O(^PSX(552.2,"AP",N)) Q:($G(N)']"") I N[BATREF D
..F J=0:0 S J=$O(^PSX(552.2,"AP",N,J)) Q:'J D
...S:J>PSXEND PSXEND=J S:PSXBEG=0 PSXBEG=J
I $D(^PSX(552.2,PSXREF,BATREF)) S (PSXBEG,X)=0 F S X=$O(^PSX(552.2,PSXREF,BATREF,X)) Q:'X S:PSXBEG=0 PSXBEG=X S PSXEND=X
CHECK I '$G(PSXBEG)!('$G(PSXEND)) S ^PSX(553,1,"P")="S" W !!,"No data to "_$S($G(REPRINT):"reprint",1:"print")_" for CMOP Msg # ",BATREF,". Select another batch.",! H 3 G START
K X D DEVICE
END S ^PSX(553,1,"P")="S"
K PSXBEG,PSXEND,BATREF,Z,ER,NTE,Q,V,C,ZZ,Z,X,Y,G,A,CT,CH1,L,PSXST
K ZY,IEN14,CNT,R554,DUOUT,DTOUT,DIRUT,DIROUT,N514
K PSXLAP,PSXREF,REPRINT,PSXBLR,POP,PSXBAR,PSXIOS,REJECT
Q
DEVICE W !! S %ZIS="MNQ",%ZIS("A")="Select Label Printer: ",%ZIS("B")=""
D ^%ZIS K %ZIS,IO("Q"),IOP G:POP END I $E(IOST,1,2)["C-" W !,"You must choose a printer or ""^"" to exit" G DEVICE
S PSXLAP=ION D PSET^%ZISP I $G(IOBARON)]"" S PSXBAR=1,PSXIOS=IOS
D ^%ZISC K J,C
TOF S DIR("A")="OK TO ASSUME LABEL ALIGNMENT IS CORRECT ?"
S DIR("B")="YES",DIR(0)="SB^Y:YES;N:NO",DIR("?")="Enter Y if labels are OK, N if they need to be aligned."
D ^DIR K DIR G:$D(DIRUT) END
G:("Yy"[$E(Y)) QUE
P2 S IOP=$G(PSXLAP) D ^%ZIS K IOP I POP W !?5,"PRINTER IS BUSY. " G TOF
U IO(0) W !,"ALIGN LABELS SO THAT A PERFORATION IS AT THE TOP OF THE"
W !,"PRINT HEAD AND THE LEFT SIDE IS AT COLUMN ZERO."
R !,"PRESS RETURN WHEN READY:",X:DTIME Q:"^"=X!'$T D PTEST^PSXLBLPT D ^%ZISC
S DIR("A")="IS THIS CORRECT ?",DIR("B")="YES"
S DIR(0)="SB^Y:YES;N:NO",DIR("?")="Enter Y if labels are OK, N if they need to be aligned."
D ^DIR K DIR G:$D(DIRUT) END
K DIR G:("Yy"[$E(Y)) QUE
G P2
QUE S ZTSAVE("PSXBEG")="",ZTSAVE("PSXEND")="",ZTSAVE("BATREF")=""
S ZTSAVE("PSXBAR")="",ZTSAVE("REPRINT")=""
S ZTSAVE("N514")="",ZTIO=PSXLAP,ZTSAVE("RESET")="",ZTSAVE("PSXREF")=""
S ZTSAVE("PSXBLR")="",ZTSAVE("IOBARON")="",ZTSAVE("IOBAROFF")=""
S ZTRTN="^PSXLBL1",ZTDESC="CMOP Host Label Print" D ^%ZTLOAD
Q1 W:$D(ZTSK) !!,"LABELS Queued to Print!!"
Q
MSG W !!,"Labels may NOT be printed while the CMOP "_$S($G(ZH)="F":"Background Filer ",1:"Interface ")_"is running.",!!,"Please try again later...",!! L -^PSX(553)
K ZH
Q
REPRINT S REPRINT=1 G START
REJECT S REJECT=1 G START
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXLBL 3223 printed Sep 23, 2025@19:20:19 Page 2
PSXLBL ;BIR/HTW,BAB-CMOP Host Label Print..User Input ; [ 05/01/97 11:47 AM ]
+1 ;;2.0;CMOP;**1**;11 Apr 97
START ;
+1 LOCK +^PSX(553):1
IF '$TEST
DO MSG
QUIT
+2 IF ^PSX(553,1,"S")="R"
DO MSG
QUIT
+3 if '$DATA(^PSX(554,"AB"))
GOTO SS
+4 SET R554=$ORDER(^PSX(554,"AB",""))
+5 IF $PIECE($GET(^PSX(554,1,1,R554,0)),"^",4)="R"
SET ZH="F"
DO MSG
QUIT
SS IF ^PSX(553,1,"S")="S"
SET ^PSX(553,1,"P")="R"
+1 LOCK -^PSX(553)
SS1 WRITE @IOF,!
SS2 SET DIC=552.1
SET DIC(0)="AEQMZ"
SET DIC("A")="Print Facility-Batch #: "
+1 IF $GET(REPRINT)
SET DIC("S")="I $P(^(0),U,2)=""3"""
SET PSXREF="AP"
GOTO ENTER
+2 IF $GET(REJECT)
SET DIC("S")="I $P(^(0),U,2)'=""2"""
SET PSXREF="AR"
GOTO ENTER
+3 SET DIC("S")="I $P(^(0),U,2)=""2"""
SET PSXREF="AQ"
ENTER DO ^DIC
KILL DIC
IF $DATA(DUOUT)!($DATA(DTOUT))!(""[X)!(X["^")
GOTO END
+1 SET BATREF=($PIECE(Y,U,2))
SET N514=+Y
KILL X,Y,DIC
+2 IF $DATA(^PSX(552.1,"APR",BATREF))
WRITE !!,"BATCH "_BATREF_" is currently being printed.",!,"Please select another batch or ""^"" to exit.",!!
KILL N514,X,Y,DIC
GOTO SS2
+3 IF $GET(REPRINT)
Begin DoDot:1
+4 SET N=""
SET (J,PSXBEG,PSXEND)=0
+5 FOR
SET N=$ORDER(^PSX(552.2,"AP",N))
if ($GET(N)']"")
QUIT
IF N[BATREF
Begin DoDot:2
+6 FOR J=0:0
SET J=$ORDER(^PSX(552.2,"AP",N,J))
if 'J
QUIT
Begin DoDot:3
+7 if J>PSXEND
SET PSXEND=J
if PSXBEG=0
SET PSXBEG=J
End DoDot:3
End DoDot:2
End DoDot:1
KILL J,N
GOTO CHECK
+8 IF $DATA(^PSX(552.2,PSXREF,BATREF))
SET (PSXBEG,X)=0
FOR
SET X=$ORDER(^PSX(552.2,PSXREF,BATREF,X))
if 'X
QUIT
if PSXBEG=0
SET PSXBEG=X
SET PSXEND=X
CHECK IF '$GET(PSXBEG)!('$GET(PSXEND))
SET ^PSX(553,1,"P")="S"
WRITE !!,"No data to "_$SELECT($GET(REPRINT):"reprint",1:"print")_" for CMOP Msg # ",BATREF,". Select another batch.",!
HANG 3
GOTO START
+1 KILL X
DO DEVICE
END SET ^PSX(553,1,"P")="S"
+1 KILL PSXBEG,PSXEND,BATREF,Z,ER,NTE,Q,V,C,ZZ,Z,X,Y,G,A,CT,CH1,L,PSXST
+2 KILL ZY,IEN14,CNT,R554,DUOUT,DTOUT,DIRUT,DIROUT,N514
+3 KILL PSXLAP,PSXREF,REPRINT,PSXBLR,POP,PSXBAR,PSXIOS,REJECT
+4 QUIT
DEVICE WRITE !!
SET %ZIS="MNQ"
SET %ZIS("A")="Select Label Printer: "
SET %ZIS("B")=""
+1 DO ^%ZIS
KILL %ZIS,IO("Q"),IOP
if POP
GOTO END
IF $EXTRACT(IOST,1,2)["C-"
WRITE !,"You must choose a printer or ""^"" to exit"
GOTO DEVICE
+2 SET PSXLAP=ION
DO PSET^%ZISP
IF $GET(IOBARON)]""
SET PSXBAR=1
SET PSXIOS=IOS
+3 DO ^%ZISC
KILL J,C
TOF SET DIR("A")="OK TO ASSUME LABEL ALIGNMENT IS CORRECT ?"
+1 SET DIR("B")="YES"
SET DIR(0)="SB^Y:YES;N:NO"
SET DIR("?")="Enter Y if labels are OK, N if they need to be aligned."
+2 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
+3 if ("Yy"[$EXTRACT(Y))
GOTO QUE
P2 SET IOP=$GET(PSXLAP)
DO ^%ZIS
KILL IOP
IF POP
WRITE !?5,"PRINTER IS BUSY. "
GOTO TOF
+1 USE IO(0)
WRITE !,"ALIGN LABELS SO THAT A PERFORATION IS AT THE TOP OF THE"
+2 WRITE !,"PRINT HEAD AND THE LEFT SIDE IS AT COLUMN ZERO."
+3 READ !,"PRESS RETURN WHEN READY:",X:DTIME
if "^"=X!'$TEST
QUIT
DO PTEST^PSXLBLPT
DO ^%ZISC
+4 SET DIR("A")="IS THIS CORRECT ?"
SET DIR("B")="YES"
+5 SET DIR(0)="SB^Y:YES;N:NO"
SET DIR("?")="Enter Y if labels are OK, N if they need to be aligned."
+6 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
+7 KILL DIR
if ("Yy"[$EXTRACT(Y))
GOTO QUE
+8 GOTO P2
QUE SET ZTSAVE("PSXBEG")=""
SET ZTSAVE("PSXEND")=""
SET ZTSAVE("BATREF")=""
+1 SET ZTSAVE("PSXBAR")=""
SET ZTSAVE("REPRINT")=""
+2 SET ZTSAVE("N514")=""
SET ZTIO=PSXLAP
SET ZTSAVE("RESET")=""
SET ZTSAVE("PSXREF")=""
+3 SET ZTSAVE("PSXBLR")=""
SET ZTSAVE("IOBARON")=""
SET ZTSAVE("IOBAROFF")=""
+4 SET ZTRTN="^PSXLBL1"
SET ZTDESC="CMOP Host Label Print"
DO ^%ZTLOAD
Q1 if $DATA(ZTSK)
WRITE !!,"LABELS Queued to Print!!"
+1 QUIT
MSG WRITE !!,"Labels may NOT be printed while the CMOP "_$SELECT($GET(ZH)="F":"Background Filer ",1:"Interface ")_"is running.",!!,"Please try again later...",!!
LOCK -^PSX(553)
+1 KILL ZH
+2 QUIT
REPRINT SET REPRINT=1
GOTO START
REJECT SET REJECT=1
GOTO START
