Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRLABLDS

LRLABLDS.m

Go to the documentation of this file.
  1. 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
  1. EN ;
  1. N DIC,DIR,DIRUT,DTOUT,DTOUT,LRBATCH,LROK,LRAA,LRAD,LRAN,LRUID
  1. K ^TMP($J)
  1. S LRBATCH=0,LRPICK=2,LRSING=1
  1. S DIR(0)="NO^1:"_$O(^LRO(69,"C",""),-1)_":0",DIR("A")="Enter Order Number"
  1. S DIR("?")="Enter the order number for which you need a label"
  1. D ^DIR
  1. I $D(DIRUT) D CLEAN Q
  1. I '$D(^LRO(69,"C",Y)) W !?10,"Number does not exist",!,$C(7) G EN
  1. S LRORDN=Y
  1. GET K DA
  1. S (LREND,LROK,LRSN)=0
  1. S LRODT=$O(^LRO(69,"C",LRORDN,""))
  1. F S LRSN=$O(^LRO(69,"C",LRORDN,LRODT,LRSN)) Q:LRSN="" D
  1. . S LRSN(0)=$G(^LRO(69,LRODT,1,LRSN,0)),LRSN(1)=$G(^LRO(69,LRODT,1,LRSN,1))
  1. . S DA=LRSN,DA(1)=LRODT,DIC="^LRO(69,"_DA(1)_",1,"
  1. . D EN^DIQ,CHK
  1. . I 'LREND S LROK=1
  1. I 'LROK G EN
  1. K DIR W !
  1. S DIR(0)="YO",DIR("A")="Is this the correct patient",DIR("B")="YES"
  1. D ^DIR
  1. I $D(DIRUT) D CLEAN Q
  1. I Y'=1 G EN
  1. K %ZIS S %ZIS="Q" D ^%ZIS
  1. I POP D CLEAN Q
  1. I $D(IO("Q")) D G EN
  1. . S ZTRTN="QUE^LRLABLDS",ZTDESC="Print Future Collection Labels"
  1. . S ZTSAVE("LR*")=""
  1. . D ^%ZTLOAD,CLEAN
  1. QUE ;
  1. U IO
  1. S (LREND,LROK,LRSN)=0
  1. F S LRSN=$O(^LRO(69,"C",LRORDN,LRODT,LRSN)) Q:LRSN="" D
  1. . S LRSN(0)=$G(^LRO(69,LRODT,1,LRSN,0)),LRSN(1)=$G(^LRO(69,LRODT,1,LRSN,1))
  1. . I '$D(ZTQUEUED) S LROK=1
  1. . E D CHK S:'LREND LROK=1 Q:LREND
  1. . S LRDFN=+LRSN(0) D BLDTMP^LRLABLD0
  1. I LROK D ^LRLABELF
  1. Q:$D(ZTQUEUED)
  1. D CLEAN
  1. G EN
  1. ;
  1. CHK ; Check order for collection type/status/date-time
  1. N LRMSG
  1. S LREND=0
  1. I '$L($P(LRSN(0),U,4)) S LREND=1,LRMSG="No Collection Type on Order"
  1. I 'LREND,'$P(LRSN(0),U,8) S LREND=1,LRMSG="No Est. Date/Time of Collection on Order"
  1. 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))
  1. I 'LREND,$P(LRSN(1),U) S LREND=1,LRMSG="Order already collected"
  1. I 'LREND D
  1. . N LRTEST,LROK
  1. . S LROK=0 ; Flag to indicate there are still tests on the order
  1. . S LRTEST=0
  1. . 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.
  1. . I 'LROK S LREND=1,LRMSG="No active tests on specimen"
  1. I LREND,'LRBATCH D Q
  1. . I $D(ZTQUEUED),LRPICK=2 Q ; Don't print error msg on label printer.
  1. . U IO(0)
  1. . W !,$C(7),"Can not print label for Order Number: ",$P($G(^LRO(69,LRODT,1,LRSN,.1),"Unknown"),U)
  1. . W !,?26,"Specimen #: ",LRSN
  1. . W !,?5,"Reason - ",LRMSG,!
  1. Q
  1. ;
  1. CLEAN ;
  1. D END^LRLABELF
  1. K DA,DIC,A,DX
  1. Q