- LRLABXT ;SLC/TGA - REPRINTS DEMAND LABELS ;2/19/91 10:38
- ;;5.2T9;LR;**1018**;Nov 17, 2004
- ;;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
- LRLABXT ;SLC/TGA - REPRINTS DEMAND LABELS ;2/19/91 10:38
- +1 ;;5.2T9;LR;**1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**80,161**;Sep 27, 1994
- +3 ;
- 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
