source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRLABLDS.m@ 1211

Last change on this file since 1211 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1LRLABLDS ;DALOI/FHS/DRH - PRINT SINGLE LABELS ON DEMAND FOR FUTURE LAB COLLECT ;8/29/94 12:36
2 ;;5.2;LAB SERVICE;**161,218**;Sep 27, 1994
3EN ;
4 N DIC,DIR,DIRUT,DTOUT,DTOUT,LRBATCH,LROK
5 K ^TMP($J)
6 S LRBATCH=0,LRPICK=2,LRSING=1
7 S DIR(0)="NO^1:"_$O(^LRO(69,"C",""),-1)_":0",DIR("A")="Enter Order Number"
8 S DIR("?")="Enter the order number for which you need a label"
9 D ^DIR
10 I $D(DIRUT) D CLEAN Q
11 I '$D(^LRO(69,"C",Y)) W !?10,"Number does not exist",!,$C(7) G EN
12 S LRORDN=Y
13GET K DA
14 S (LREND,LROK,LRSN)=0
15 S LRODT=$O(^LRO(69,"C",LRORDN,""))
16 F S LRSN=$O(^LRO(69,"C",LRORDN,LRODT,LRSN)) Q:LRSN="" D
17 . S LRSN(0)=$G(^LRO(69,LRODT,1,LRSN,0)),LRSN(1)=$G(^LRO(69,LRODT,1,LRSN,1))
18 . S DA=LRSN,DA(1)=LRODT,DIC="^LRO(69,"_DA(1)_",1,"
19 . D EN^DIQ,CHK
20 . I 'LREND S LROK=1
21 I 'LROK G EN
22 K DIR W !
23 S DIR(0)="YO",DIR("A")="Is this the correct patient",DIR("B")="YES"
24 D ^DIR
25 I $D(DIRUT) D CLEAN Q
26 I Y'=1 G EN
27 K %ZIS S %ZIS="Q" D ^%ZIS
28 I POP D CLEAN Q
29 I $D(IO("Q")) D G EN
30 . S ZTRTN="QUE^LRLABLDS",ZTDESC="Print Future Collection Labels"
31 . S ZTSAVE("LR*")=""
32 . D ^%ZTLOAD,CLEAN
33QUE ;
34 U IO
35 S (LREND,LROK,LRSN)=0
36 F S LRSN=$O(^LRO(69,"C",LRORDN,LRODT,LRSN)) Q:LRSN="" D
37 . S LRSN(0)=$G(^LRO(69,LRODT,1,LRSN,0)),LRSN(1)=$G(^LRO(69,LRODT,1,LRSN,1))
38 . I '$D(ZTQUEUED) S LROK=1
39 . E D CHK S:'LREND LROK=1 Q:LREND
40 . S LRDFN=+LRSN(0) D BLDTMP^LRLABLD0
41 I LROK D ^LRLABELF
42 Q:$D(ZTQUEUED)
43 D CLEAN
44 G EN
45 ;
46CHK ; Check order for collection type/status/date-time
47 N LRMSG
48 S LREND=0
49 I '$L($P(LRSN(0),U,4)) S LREND=1,LRMSG="No Collection Type on Order"
50 I 'LREND,'$P(LRSN(0),U,8) S LREND=1,LRMSG="No Est. Date/Time of Collection on Order"
51 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))
52 I 'LREND,$P(LRSN(1),U) S LREND=1,LRMSG="Order already collected"
53 I 'LREND D
54 . N LRTEST,LROK
55 . S LROK=0 ; Flag to indicate there are still tests on the order
56 . S LRTEST=0
57 . 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.
58 . I 'LROK S LREND=1,LRMSG="No active tests on specimen"
59 I LREND,'LRBATCH D Q
60 . I $D(ZTQUEUED),LRPICK=2 Q ; Don't print error msg on label printer.
61 . U IO(0)
62 . W !,$C(7),"Can not print label for Order Number: ",$P($G(^LRO(69,LRODT,1,LRSN,.1),"Unknown"),U)
63 . W !,?26,"Specimen #: ",LRSN
64 . W !,?5,"Reason - ",LRMSG,!
65 Q
66 ;
67CLEAN ;
68 D END^LRLABELF
69 K DA,DIC,A,DX
70 Q
Note: See TracBrowser for help on using the repository browser.