LRLABLDS ;DALOI/FHS/DRH - PRINT SINGLE LABELS ON DEMAND FOR FUTURE LAB COLLECT ;8/29/94 12:36
;;5.2;LAB SERVICE;**161,218,445**;Sep 27, 1994;Build 6
EN ;
N DIC,DIR,DIRUT,DTOUT,DTOUT,LRBATCH,LROK,LRAA,LRAD,LRAN,LRUID
K ^TMP($J)
S LRBATCH=0,LRPICK=2,LRSING=1
S DIR(0)="NO^1:"_$O(^LRO(69,"C",""),-1)_":0",DIR("A")="Enter Order Number"
S DIR("?")="Enter the order number for which you need a label"
D ^DIR
I $D(DIRUT) D CLEAN Q
I '$D(^LRO(69,"C",Y)) W !?10,"Number does not exist",!,$C(7) G EN
S LRORDN=Y
GET K DA
S (LREND,LROK,LRSN)=0
S LRODT=$O(^LRO(69,"C",LRORDN,""))
F S LRSN=$O(^LRO(69,"C",LRORDN,LRODT,LRSN)) Q:LRSN="" D
. S LRSN(0)=$G(^LRO(69,LRODT,1,LRSN,0)),LRSN(1)=$G(^LRO(69,LRODT,1,LRSN,1))
. S DA=LRSN,DA(1)=LRODT,DIC="^LRO(69,"_DA(1)_",1,"
. D EN^DIQ,CHK
. I 'LREND S LROK=1
I 'LROK G EN
K DIR W !
S DIR(0)="YO",DIR("A")="Is this the correct patient",DIR("B")="YES"
D ^DIR
I $D(DIRUT) D CLEAN Q
I Y'=1 G EN
K %ZIS S %ZIS="Q" D ^%ZIS
I POP D CLEAN Q
I $D(IO("Q")) D G EN
. S ZTRTN="QUE^LRLABLDS",ZTDESC="Print Future Collection Labels"
. S ZTSAVE("LR*")=""
. D ^%ZTLOAD,CLEAN
QUE ;
U IO
S (LREND,LROK,LRSN)=0
F S LRSN=$O(^LRO(69,"C",LRORDN,LRODT,LRSN)) Q:LRSN="" D
. S LRSN(0)=$G(^LRO(69,LRODT,1,LRSN,0)),LRSN(1)=$G(^LRO(69,LRODT,1,LRSN,1))
. I '$D(ZTQUEUED) S LROK=1
. E D CHK S:'LREND LROK=1 Q:LREND
. S LRDFN=+LRSN(0) D BLDTMP^LRLABLD0
I LROK D ^LRLABELF
Q:$D(ZTQUEUED)
D CLEAN
G EN
;
CHK ; Check order for collection type/status/date-time
N LRMSG
S LREND=0
I '$L($P(LRSN(0),U,4)) S LREND=1,LRMSG="No Collection Type on Order"
I 'LREND,'$P(LRSN(0),U,8) S LREND=1,LRMSG="No Est. Date/Time of Collection on Order"
I 'LREND,$L($P(LRSN(1),U,4)),"CM"[$P(LRSN(1),U,4) S LREND=1,LRMSG="Collection status: "_$$EXTERNAL^DILFD(69.01,13,,$P(LRSN(1),U,4))
I 'LREND,$P(LRSN(1),U) S LREND=1,LRMSG="Order already collected"
I 'LREND D
. N LRTEST,LROK
. S LROK=0 ; Flag to indicate there are still tests on the order
. S LRTEST=0
. F S LRTEST=$O(^LRO(69,LRODT,1,LRSN,2,LRTEST)) Q:'LRTEST I '$P($G(^LRO(69,LRODT,1,LRSN,2,LRTEST,0)),U,11) S LROK=1 ; Found a 'good' test.
. I 'LROK S LREND=1,LRMSG="No active tests on specimen"
I LREND,'LRBATCH D Q
. I $D(ZTQUEUED),LRPICK=2 Q ; Don't print error msg on label printer.
. U IO(0)
. W !,$C(7),"Can not print label for Order Number: ",$P($G(^LRO(69,LRODT,1,LRSN,.1),"Unknown"),U)
. W !,?26,"Specimen #: ",LRSN
. W !,?5,"Reason - ",LRMSG,!
Q
;
CLEAN ;
D END^LRLABELF
K DA,DIC,A,DX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLABLDS 2566 printed Apr 09, 2024@21:14:31 Page 2
LRLABLDS ;DALOI/FHS/DRH - PRINT SINGLE LABELS ON DEMAND FOR FUTURE LAB COLLECT ;8/29/94 12:36
+1 ;;5.2;LAB SERVICE;**161,218,445**;Sep 27, 1994;Build 6
EN ;
+1 NEW DIC,DIR,DIRUT,DTOUT,DTOUT,LRBATCH,LROK,LRAA,LRAD,LRAN,LRUID
+2 KILL ^TMP($JOB)
+3 SET LRBATCH=0
SET LRPICK=2
SET LRSING=1
+4 SET DIR(0)="NO^1:"_$ORDER(^LRO(69,"C",""),-1)_":0"
SET DIR("A")="Enter Order Number"
+5 SET DIR("?")="Enter the order number for which you need a label"
+6 DO ^DIR
+7 IF $DATA(DIRUT)
DO CLEAN
QUIT
+8 IF '$DATA(^LRO(69,"C",Y))
WRITE !?10,"Number does not exist",!,$CHAR(7)
GOTO EN
+9 SET LRORDN=Y
GET KILL DA
+1 SET (LREND,LROK,LRSN)=0
+2 SET LRODT=$ORDER(^LRO(69,"C",LRORDN,""))
+3 FOR
SET LRSN=$ORDER(^LRO(69,"C",LRORDN,LRODT,LRSN))
if LRSN=""
QUIT
Begin DoDot:1
+4 SET LRSN(0)=$GET(^LRO(69,LRODT,1,LRSN,0))
SET LRSN(1)=$GET(^LRO(69,LRODT,1,LRSN,1))
+5 SET DA=LRSN
SET DA(1)=LRODT
SET DIC="^LRO(69,"_DA(1)_",1,"
+6 DO EN^DIQ
DO CHK
+7 IF 'LREND
SET LROK=1
End DoDot:1
+8 IF 'LROK
GOTO EN
+9 KILL DIR
WRITE !
+10 SET DIR(0)="YO"
SET DIR("A")="Is this the correct patient"
SET DIR("B")="YES"
+11 DO ^DIR
+12 IF $DATA(DIRUT)
DO CLEAN
QUIT
+13 IF Y'=1
GOTO EN
+14 KILL %ZIS
SET %ZIS="Q"
DO ^%ZIS
+15 IF POP
DO CLEAN
QUIT
+16 IF $DATA(IO("Q"))
Begin DoDot:1
+17 SET ZTRTN="QUE^LRLABLDS"
SET ZTDESC="Print Future Collection Labels"
+18 SET ZTSAVE("LR*")=""
+19 DO ^%ZTLOAD
DO CLEAN
End DoDot:1
GOTO EN
QUE ;
+1 USE IO
+2 SET (LREND,LROK,LRSN)=0
+3 FOR
SET LRSN=$ORDER(^LRO(69,"C",LRORDN,LRODT,LRSN))
if LRSN=""
QUIT
Begin DoDot:1
+4 SET LRSN(0)=$GET(^LRO(69,LRODT,1,LRSN,0))
SET LRSN(1)=$GET(^LRO(69,LRODT,1,LRSN,1))
+5 IF '$DATA(ZTQUEUED)
SET LROK=1
+6 IF '$TEST
DO CHK
if 'LREND
SET LROK=1
if LREND
QUIT
+7 SET LRDFN=+LRSN(0)
DO BLDTMP^LRLABLD0
End DoDot:1
+8 IF LROK
DO ^LRLABELF
+9 if $DATA(ZTQUEUED)
QUIT
+10 DO CLEAN
+11 GOTO EN
+12 ;
CHK ; Check order for collection type/status/date-time
+1 NEW LRMSG
+2 SET LREND=0
+3 IF '$LENGTH($PIECE(LRSN(0),U,4))
SET LREND=1
SET LRMSG="No Collection Type on Order"
+4 IF 'LREND
IF '$PIECE(LRSN(0),U,8)
SET LREND=1
SET LRMSG="No Est. Date/Time of Collection on Order"
+5 IF 'LREND
IF $LENGTH($PIECE(LRSN(1),U,4))
IF "CM"[$PIECE(LRSN(1),U,4)
SET LREND=1
SET LRMSG="Collection status: "_$$EXTERNAL^DILFD(69.01,13,,$PIECE(LRSN(1),U,4))
+6 IF 'LREND
IF $PIECE(LRSN(1),U)
SET LREND=1
SET LRMSG="Order already collected"
+7 IF 'LREND
Begin DoDot:1
+8 NEW LRTEST,LROK
+9 ; Flag to indicate there are still tests on the order
SET LROK=0
+10 SET LRTEST=0
+11 ; Found a 'good' test.
FOR
SET LRTEST=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTEST))
if 'LRTEST
QUIT
IF '$PIECE($GET(^LRO(69,LRODT,1,LRSN,2,LRTEST,0)),U,11)
SET LROK=1
+12 IF 'LROK
SET LREND=1
SET LRMSG="No active tests on specimen"
End DoDot:1
+13 IF LREND
IF 'LRBATCH
Begin DoDot:1
+14 ; Don't print error msg on label printer.
IF $DATA(ZTQUEUED)
IF LRPICK=2
QUIT
+15 USE IO(0)
+16 WRITE !,$CHAR(7),"Can not print label for Order Number: ",$PIECE($GET(^LRO(69,LRODT,1,LRSN,.1),"Unknown"),U)
+17 WRITE !,?26,"Specimen #: ",LRSN
+18 WRITE !,?5,"Reason - ",LRMSG,!
End DoDot:1
QUIT
+19 QUIT
+20 ;
CLEAN ;
+1 DO END^LRLABELF
+2 KILL DA,DIC,A,DX
+3 QUIT
