- 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 Jan 18, 2025@03:16:48 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