- LRLABXOL ;RVAMC/PLS/DALISC/FHS - REPRINT ACCESSION LABELS FOR ENTIRE ORDER ; 5/19/93 07:40
- ;;5.2T9;LR;**1018**;Nov 17, 2004
- ;;5.2;LAB SERVICE;**11,121,161**;Sep 27, 1994
- ; Will print all the required labels for a entire order.
- EN K ZTSK
- D IOCHK^LRLABXT G END:'$D(LRLABLIO)
- D PSET^LRLABLD
- S LRHDR="Select Order Number: "
- 1 U IO(0)
- W !!,LRHDR R LRORD:DTIME G:'$T END G:(LRORD="")!(LRORD="^") END I LRORD?.AP!(LRORD<1) W !,"Enter a whole number for the order number." G 1
- S LRORD=+LRORD
- S LRODT=$O(^LRO(69,"C",LRORD,0))
- I +LRODT<1 W " ORDER NUMBER NOT FOUND" G 1
- I '$$GOT^LROE(LRORD,LRODT) W !!,"All tests for this order have been canceled." H 1 G 1
- I $D(LRLABLIO("Q")) D G END
- . S ZTIO=LRLABLIO,ZTRTN="QUE^LRLABXOL",ZTDESC="LAB ORDER LABELS",ZTSAVE("LR*")=""
- . D ^%ZTLOAD
- . W !,"Labels have been tasked to print ",!
- D QUE
- K LRORD
- U IO(0) W !?10,"Label(s) Printed",! S LRHDR="Another Order Number: "
- G 1
- ;
- QUE ;
- S LRODT=0
- F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 D 2,PRINT
- I $D(ZTQUEUED) S ZTREQ="@"
- Q
- ;
- 2 ;
- S LRSN=0
- F S LRSN=+$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1 D SQ
- Q
- ;
- SQ ; Search for accession numbers and build LRORD array 'ORD #(SEQ #,ACC AREA,ACC DATE, ACC #)=""'
- Q:'$D(^LRO(69,LRODT,1,LRSN,2,0))
- S SEQ=0
- F S SEQ=+$O(^LRO(69,LRODT,1,LRSN,2,SEQ)) Q:SEQ<1 D
- . S X=$G(^LRO(69,LRODT,1,LRSN,2,SEQ,0)),LRAD=$P(X,U,3),LRAA=$P(X,U,4),LRAN=$P(X,U,5)
- . I LRAA,LRAD,LRAN S LRORD(LRSN,LRAA,LRAD,LRAN)=""
- Q
- ;
- PRINT ; Loop thru array and print labels.
- U IO
- S LRAA=""
- F S LRX=$Q(LRORD) Q:LRX="" Q:$QS(LRX,0)'="LRORD" D
- . S LRSN=$QS(LRX,1)
- . I LRAA'=$QS(LRX,2) S LRAA=$QS(LRX,2) D LBLTYP^LRLABLD
- . S LRAD=$QS(LRX,3),LRAN=$QS(LRX,4)
- . K LRORD(LRSN,LRAA,LRAD,LRAN)
- . N LRORD,LRX
- . D PRINT^LRLABXT
- Q
- ;
- END ;
- K LRHDR,LRORD,SEQ,ZTSK
- D K^LRLABXT
- Q
- LRLABXOL ;RVAMC/PLS/DALISC/FHS - REPRINT ACCESSION LABELS FOR ENTIRE ORDER ; 5/19/93 07:40
- +1 ;;5.2T9;LR;**1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**11,121,161**;Sep 27, 1994
- +3 ; Will print all the required labels for a entire order.
- EN KILL ZTSK
- +1 DO IOCHK^LRLABXT
- IF '$DATA(LRLABLIO)
- GOTO END
- +2 DO PSET^LRLABLD
- +3 SET LRHDR="Select Order Number: "
- 1 USE IO(0)
- +1 WRITE !!,LRHDR
- READ LRORD:DTIME
- IF '$TEST
- GOTO END
- IF (LRORD="")!(LRORD="^")
- GOTO END
- IF LRORD?.AP!(LRORD<1)
- WRITE !,"Enter a whole number for the order number."
- GOTO 1
- +2 SET LRORD=+LRORD
- +3 SET LRODT=$ORDER(^LRO(69,"C",LRORD,0))
- +4 IF +LRODT<1
- WRITE " ORDER NUMBER NOT FOUND"
- GOTO 1
- +5 IF '$$GOT^LROE(LRORD,LRODT)
- WRITE !!,"All tests for this order have been canceled."
- HANG 1
- GOTO 1
- +6 IF $DATA(LRLABLIO("Q"))
- Begin DoDot:1
- +7 SET ZTIO=LRLABLIO
- SET ZTRTN="QUE^LRLABXOL"
- SET ZTDESC="LAB ORDER LABELS"
- SET ZTSAVE("LR*")=""
- +8 DO ^%ZTLOAD
- +9 WRITE !,"Labels have been tasked to print ",!
- End DoDot:1
- GOTO END
- +10 DO QUE
- +11 KILL LRORD
- +12 USE IO(0)
- WRITE !?10,"Label(s) Printed",!
- SET LRHDR="Another Order Number: "
- +13 GOTO 1
- +14 ;
- QUE ;
- +1 SET LRODT=0
- +2 FOR
- SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
- IF LRODT<1
- QUIT
- DO 2
- DO PRINT
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +4 QUIT
- +5 ;
- 2 ;
- +1 SET LRSN=0
- +2 FOR
- SET LRSN=+$ORDER(^LRO(69,"C",LRORD,LRODT,LRSN))
- IF LRSN<1
- QUIT
- DO SQ
- +3 QUIT
- +4 ;
- SQ ; Search for accession numbers and build LRORD array 'ORD #(SEQ #,ACC AREA,ACC DATE, ACC #)=""'
- +1 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,0))
- QUIT
- +2 SET SEQ=0
- +3 FOR
- SET SEQ=+$ORDER(^LRO(69,LRODT,1,LRSN,2,SEQ))
- IF SEQ<1
- QUIT
- Begin DoDot:1
- +4 SET X=$GET(^LRO(69,LRODT,1,LRSN,2,SEQ,0))
- SET LRAD=$PIECE(X,U,3)
- SET LRAA=$PIECE(X,U,4)
- SET LRAN=$PIECE(X,U,5)
- +5 IF LRAA
- IF LRAD
- IF LRAN
- SET LRORD(LRSN,LRAA,LRAD,LRAN)=""
- End DoDot:1
- +6 QUIT
- +7 ;
- PRINT ; Loop thru array and print labels.
- +1 USE IO
- +2 SET LRAA=""
- +3 FOR
- SET LRX=$QUERY(LRORD)
- IF LRX=""
- QUIT
- IF $QSUBSCRIPT(LRX,0)'="LRORD"
- QUIT
- Begin DoDot:1
- +4 SET LRSN=$QSUBSCRIPT(LRX,1)
- +5 IF LRAA'=$QSUBSCRIPT(LRX,2)
- SET LRAA=$QSUBSCRIPT(LRX,2)
- DO LBLTYP^LRLABLD
- +6 SET LRAD=$QSUBSCRIPT(LRX,3)
- SET LRAN=$QSUBSCRIPT(LRX,4)
- +7 KILL LRORD(LRSN,LRAA,LRAD,LRAN)
- +8 NEW LRORD,LRX
- +9 DO PRINT^LRLABXT
- End DoDot:1
- +10 QUIT
- +11 ;
- END ;
- +1 KILL LRHDR,LRORD,SEQ,ZTSK
- +2 DO K^LRLABXT
- +3 QUIT
