LRLABXT ;SLC/TGA - REPRINTS DEMAND LABELS ;2/19/91 10:38
;;5.2;LAB SERVICE;**80,161**;Sep 27, 1994
;
EN ; Reprint labels
D IOCHK
I '$D(LRLABLIO) D K Q
D OPEN^%ZISUTL("LRHOME","HOME") ; Setup handle for user's "HOME" device.
D USE^%ZISUTL("LRHOME")
K DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SO^1:Range of Accessions;2:Selected Accessions",DIR("A")="Selection Method",DIR("B")=1
D ^DIR
I $D(DIRUT) D K Q
S LRTYPE=+Y
ASK ;
D USE^%ZISUTL("LRHOME")
S (LRACC,LREXMPT)=1,(LRCNT,LRQUIT)=0
K ^TMP("LRLABXT",$J)
I LRTYPE=1 D
. D ^LRWU4
. I LRAN<1 S LRQUIT=1 Q ; User aborted selection.
. S FIRST=LRAN,X=$O(^LRO(68,LRAA,1,LRAD,1,":"),-1)
. W !
. S DIR(0)="NO^"_LRAN_":"_X_":0",DIR("A")="Reprint from "_LRAN_" to",DIR("B")=LRAN
. D ^DIR K DIR
. I $D(DIRUT) S LRQUIT=1 Q
. W !
. S LRAN=FIRST-1,LAST=Y
. F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) Q:'LRAN!(LRAN>LAST) D
. . W:$X>(IOM-1) ! W "." ; Let user know we're looking.
. . D SETTMP
I LRTYPE=2 F D Q:LRQUIT!(LRAN<1)
. D ^LRWU4
. I $D(DTOUT)!($D(DUOUT)) S LRQUIT=1 Q
. I LRAN<1 S:'$D(^TMP("LRLABXT",$J)) LRQUIT=1 Q
. D SETTMP
I 'LRQUIT,LRCNT>10 D
. N DIR,DIRUT,DTOUT,DUOUT,X,Y
. S DIR(0)="YO",DIR("A",1)="Reprinting labels for "_LRCNT_" accessions!",DIR("A")="Are you sure",DIR("B")="NO"
. D ^DIR
. I Y<1!($D(DIRUT)) S LRQUIT=1 Q
I LRQUIT D K Q
I $D(LRLABLIO("Q")) D G ASK
. S ZTIO=LRLABLIO,ZTRTN="LOAD^LRLABXT",ZTDESC="Reprint Lab Accession Labels"
. S ZTSAVE("^TMP(""LRLABXT"",$J,")=""
. D ^%ZTLOAD
. W !,"Labels ",$S($G(ZTSK):"queued to "_$P(LRLABLIO,";")_" Task #"_ZTSK,1:"NOT queued"),!
. K ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE
W !!,"Printing labels on ",$P(LRLABLIO,";"),!
D USE^%ZISUTL("LRLABEL")
LOAD ; Tasked entry point and from above.
D PSET^LRLABLD
F S LRLABX=$Q(^TMP("LRLABXT",$J)) Q:LRLABX="" Q:$QS(LRLABX,1)'="LRLABXT"!($QS(LRLABX,2)'=$J) D
. S LRAA=$QS(LRLABX,3),LRAD=$QS(LRLABX,4),LRAN=$QS(LRLABX,5)
. D LBLTYP^LRLABLD
. D PRINT
. K @LRLABX
I $D(ZTQUEUED) D K Q
G ASK
;
PRINT ;
; Called by above, LRLABXOL
Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRSN=+$P(X,U,5),LRODT=+$P(X,U,4),LRLLOC=$P(X,U,7)
S LRCE=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)),"^")
S LRACC=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")
S LRRB=0
D LRBAR^LRLABLD
D GO^LRLABLD
Q
;
IOCHK ; Select and check label printer.
; Called from above, LRLABXOL
I '$D(LRLABLIO) D
. D ^LRLABLIO
. ; Time delay - allow port to be reopened if closed in call to LRLABLIO
. I $D(LRLABLIO),'$D(IO("Q")) H 2
I '$D(LRLABLIO) Q
I '$D(LRLABLIO("Q")) D
. N %ZIS,IOP
. S %ZIS="",IOP=LRLABLIO
. D OPEN^%ZISUTL("LRLABEL",IOP,.%ZIS) ; Setup handle for user's LABEL device.
. I POP D
. . W !,$C(7),"Unable to open device"
. . K LRLABLIO
Q
;
SETTMP ; Setup TMP global with accession to reprint.
S LRCNT=LRCNT+1,^TMP("LRLABXT",$J,LRAA,LRAD,LRAN)=""
Q
;
K ; Cleanup
I $D(ZTQUEUED) S ZTREQ="@"
E D CLOSE^%ZISUTL("LRLABEL"),CLOSE^%ZISUTL("LRHOME"),PKILL^%ZISP
D KVAR^LRX
K %,IO("Q"),A,B,DIC,I,I1,IOP,J,K,L,LAST,N,POP,R,S1,S2,T,X,Y,Z
K LRAA,LRACC,LRAD,LRAN,LRCE,LRCNT,LRDAT,LRDPF,LREXMPT,LRINFW,LRLABEL,LRLF,LRDFN,LRODT,LRPREF,LRSSP
K LRNOLABL,LRPRAC,LRTJ,LRTJDATA,LRLABX,LRQUIT,LRTOP,LRTS,LRTYPE,LRTV,LRTVOL,LRTXT,LRVOL,LRLABLIO,LRFN,LRAD,LRLLOC,LRNN,LRRB,LRSN
K LRX,LRXL,LRBAR,LRBAR1,LRBAR0,LRBARID,LRUID,LRURG,LRURG0,LRURGA
K ^TMP("LRLABXT",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLABXT 3453 printed Dec 13, 2024@02:16:09 Page 2
LRLABXT ;SLC/TGA - REPRINTS DEMAND LABELS ;2/19/91 10:38
+1 ;;5.2;LAB SERVICE;**80,161**;Sep 27, 1994
+2 ;
EN ; Reprint labels
+1 DO IOCHK
+2 IF '$DATA(LRLABLIO)
DO K
QUIT
+3 ; Setup handle for user's "HOME" device.
DO OPEN^%ZISUTL("LRHOME","HOME")
+4 DO USE^%ZISUTL("LRHOME")
+5 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+6 SET DIR(0)="SO^1:Range of Accessions;2:Selected Accessions"
SET DIR("A")="Selection Method"
SET DIR("B")=1
+7 DO ^DIR
+8 IF $DATA(DIRUT)
DO K
QUIT
+9 SET LRTYPE=+Y
ASK ;
+1 DO USE^%ZISUTL("LRHOME")
+2 SET (LRACC,LREXMPT)=1
SET (LRCNT,LRQUIT)=0
+3 KILL ^TMP("LRLABXT",$JOB)
+4 IF LRTYPE=1
Begin DoDot:1
+5 DO ^LRWU4
+6 ; User aborted selection.
IF LRAN<1
SET LRQUIT=1
QUIT
+7 SET FIRST=LRAN
SET X=$ORDER(^LRO(68,LRAA,1,LRAD,1,":"),-1)
+8 WRITE !
+9 SET DIR(0)="NO^"_LRAN_":"_X_":0"
SET DIR("A")="Reprint from "_LRAN_" to"
SET DIR("B")=LRAN
+10 DO ^DIR
KILL DIR
+11 IF $DATA(DIRUT)
SET LRQUIT=1
QUIT
+12 WRITE !
+13 SET LRAN=FIRST-1
SET LAST=Y
+14 FOR
SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
if 'LRAN!(LRAN>LAST)
QUIT
Begin DoDot:2
+15 ; Let user know we're looking.
if $X>(IOM-1)
WRITE !
WRITE "."
+16 DO SETTMP
End DoDot:2
End DoDot:1
+17 IF LRTYPE=2
FOR
Begin DoDot:1
+18 DO ^LRWU4
+19 IF $DATA(DTOUT)!($DATA(DUOUT))
SET LRQUIT=1
QUIT
+20 IF LRAN<1
if '$DATA(^TMP("LRLABXT",$JOB))
SET LRQUIT=1
QUIT
+21 DO SETTMP
End DoDot:1
if LRQUIT!(LRAN<1)
QUIT
+22 IF 'LRQUIT
IF LRCNT>10
Begin DoDot:1
+23 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+24 SET DIR(0)="YO"
SET DIR("A",1)="Reprinting labels for "_LRCNT_" accessions!"
SET DIR("A")="Are you sure"
SET DIR("B")="NO"
+25 DO ^DIR
+26 IF Y<1!($DATA(DIRUT))
SET LRQUIT=1
QUIT
End DoDot:1
+27 IF LRQUIT
DO K
QUIT
+28 IF $DATA(LRLABLIO("Q"))
Begin DoDot:1
+29 SET ZTIO=LRLABLIO
SET ZTRTN="LOAD^LRLABXT"
SET ZTDESC="Reprint Lab Accession Labels"
+30 SET ZTSAVE("^TMP(""LRLABXT"",$J,")=""
+31 DO ^%ZTLOAD
+32 WRITE !,"Labels ",$SELECT($GET(ZTSK):"queued to "_$PIECE(LRLABLIO,";")_" Task #"_ZTSK,1:"NOT queued"),!
+33 KILL ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE
End DoDot:1
GOTO ASK
+34 WRITE !!,"Printing labels on ",$PIECE(LRLABLIO,";"),!
+35 DO USE^%ZISUTL("LRLABEL")
LOAD ; Tasked entry point and from above.
+1 DO PSET^LRLABLD
+2 FOR
SET LRLABX=$QUERY(^TMP("LRLABXT",$JOB))
if LRLABX=""
QUIT
if $QSUBSCRIPT(LRLABX,1)'="LRLABXT"!($QSUBSCRIPT(LRLABX,2)'=$JOB)
QUIT
Begin DoDot:1
+3 SET LRAA=$QSUBSCRIPT(LRLABX,3)
SET LRAD=$QSUBSCRIPT(LRLABX,4)
SET LRAN=$QSUBSCRIPT(LRLABX,5)
+4 DO LBLTYP^LRLABLD
+5 DO PRINT
+6 KILL @LRLABX
End DoDot:1
+7 IF $DATA(ZTQUEUED)
DO K
QUIT
+8 GOTO ASK
+9 ;
PRINT ;
+1 ; Called by above, LRLABXOL
+2 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
+3 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRSN=+$PIECE(X,U,5)
SET LRODT=+$PIECE(X,U,4)
SET LRLLOC=$PIECE(X,U,7)
+4 SET LRCE=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)),"^")
+5 SET LRACC=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")
+6 SET LRRB=0
+7 DO LRBAR^LRLABLD
+8 DO GO^LRLABLD
+9 QUIT
+10 ;
IOCHK ; Select and check label printer.
+1 ; Called from above, LRLABXOL
+2 IF '$DATA(LRLABLIO)
Begin DoDot:1
+3 DO ^LRLABLIO
+4 ; Time delay - allow port to be reopened if closed in call to LRLABLIO
+5 IF $DATA(LRLABLIO)
IF '$DATA(IO("Q"))
HANG 2
End DoDot:1
+6 IF '$DATA(LRLABLIO)
QUIT
+7 IF '$DATA(LRLABLIO("Q"))
Begin DoDot:1
+8 NEW %ZIS,IOP
+9 SET %ZIS=""
SET IOP=LRLABLIO
+10 ; Setup handle for user's LABEL device.
DO OPEN^%ZISUTL("LRLABEL",IOP,.%ZIS)
+11 IF POP
Begin DoDot:2
+12 WRITE !,$CHAR(7),"Unable to open device"
+13 KILL LRLABLIO
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
SETTMP ; Setup TMP global with accession to reprint.
+1 SET LRCNT=LRCNT+1
SET ^TMP("LRLABXT",$JOB,LRAA,LRAD,LRAN)=""
+2 QUIT
+3 ;
K ; Cleanup
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$TEST
DO CLOSE^%ZISUTL("LRLABEL")
DO CLOSE^%ZISUTL("LRHOME")
DO PKILL^%ZISP
+3 DO KVAR^LRX
+4 KILL %,IO("Q"),A,B,DIC,I,I1,IOP,J,K,L,LAST,N,POP,R,S1,S2,T,X,Y,Z
+5 KILL LRAA,LRACC,LRAD,LRAN,LRCE,LRCNT,LRDAT,LRDPF,LREXMPT,LRINFW,LRLABEL,LRLF,LRDFN,LRODT,LRPREF,LRSSP
+6 KILL LRNOLABL,LRPRAC,LRTJ,LRTJDATA,LRLABX,LRQUIT,LRTOP,LRTS,LRTYPE,LRTV,LRTVOL,LRTXT,LRVOL,LRLABLIO,LRFN,LRAD,LRLLOC,LRNN,LRRB,LRSN
+7 KILL LRX,LRXL,LRBAR,LRBAR1,LRBAR0,LRBARID,LRUID,LRURG,LRURG0,LRURGA
+8 KILL ^TMP("LRLABXT",$JOB)
+9 QUIT
