source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRLABLIO.m@ 1661

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

initial load of WorldVistAEHR
File size: 3.1 KB
Line 
1LRLABLIO ;DALOI/TGA/JMC - TESTS LABEL PRINTER ;8/8/89 11:17
2 ;;5.2;LAB SERVICE;**107,161,218**;Sep 27, 1994
3 ;
4 ; Reference to File #3.5 supported by DBIA #2469
5 ;
61 ;
7 S U="^" Q:$D(LRLABLIO)
8 ;
9 N %ZIS,DIR,DIRUT,DTOUT,DUOUT,IOP,LRLABEL,POP,X,Y
10 ;
11 ; Setup handle for user's "HOME" device.
12 D OPEN^%ZISUTL("LRHOME","HOME")
13 ;
14 S %ZIS("B")="LABLABEL"
15 ;
16 ; Check if label device assigned to this user's HOME Device file entry.
17 I $G(IOS) D
18 . S X=$$GET1^DIQ(3.5,IOS_",",101,"E")
19 . I $L(X) S %ZIS("B")=X
20 ;
21 I %ZIS("B")="LABLABEL",$D(^LAB(69.9,1,3.5,+$G(DUZ(2)),0)) D
22 . ; Get this division's default printer
23 . S %ZIS("B")=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,3)
24 I %ZIS("B")="" S %ZIS("B")="LABLABEL"
25 S %ZIS("A")="Print labels on: ",%ZIS="NQ"
26 ; Setup handle for user's LABEL device.
272 D OPEN^%ZISUTL("LRLABEL",,.%ZIS)
28 I POP!(IO=IO(0)) D BD Q
29 S LRLABLIO=ION_";"_IOST_";"_IOM_";"_IOSL
30 I $D(IO("Q")) S LRLABLIO("Q")=1
31 I $E(IOST,1)'="P" D G:Y'=1 2
32 . N DIR,DIRUT,DTOUT,DUOUT
33 . D USE^%ZISUTL("LRHOME")
34 . S DIR(0)="YAO",DIR("A",1)="NOT printing on a printer.",DIR("A")="Are you sure"
35 . D ^DIR
36 ; Device on another cpu, can't test.
37 I $D(IOCPU) D Q
38 . N MSG
39 . S MSG="Device "_ION_" is on CPU '"_IOCPU_"' - Unable to test"
40 . D USE^%ZISUTL("LRHOME")
41 . D EN^DDIOL(MSG,"","!?5")
42 . D K
43 ;
443 I $D(LRLABLIO("Q")) D K Q
45 D USE^%ZISUTL("LRHOME")
46 W !
47 K DIR,DIRUT,DTOUT,DUOUT,X,Y
48 S DIR(0)="YAO",DIR("A")="Do you wish to test the label printer: ",DIR("B")="NO"
49 S DIR("?")="Enter 'YES' if you want to test the printer, 'NO' if you do not."
50 D ^DIR
51 I $D(DIRUT) D BD Q
52 I Y<1 G K ; Don't want to test
53 D OPEN^%ZISUTL("LRLABEL",LRLABLIO)
54 I POP D G 1
55 . D USE^%ZISUTL("LRHOME")
56 . D EN^DDIOL("Device in use - try later","","!")
57 . K LRLABLIO
58 N LRAA
59 S LRAA=0
60 D LBLTYP^LRLABLD
61 ;
62T ; Print test label
63 D USE^%ZISUTL("LRHOME")
64 K DIR,DIRUT,DTOUT,DUOUT,X,Y
65 W !!,"Using label routine: ",LRLABEL,!
66 S DIR(0)="E"
67 S DIR("A",1)="Load and position label stock as appropriate for this printer."
68 S DIR("A")="Press return when ready"
69 D ^DIR
70 I Y'=1 D BD Q
71 ;
72 N I,N,PNM,SSN
73 N LRACC,LRBAR,LRBARID,LRCE,LRDAT,LRINFW,LRLLOC,LRPREF,LRAN,LRRB,LRTOP,LRTS,LRUID,LRURG,LRURG0,LRURGA,LRXL
74 ;
75 ; Set up variables for test label
76 S PNM="TEST-LABEL-DO-NOT-USE",SSN="000-00-0000P",LRDAT="XX/XX/XX",LRLLOC="LAB",LRRB=1
77 S LRACC="SITE-TEST-LABEL",LRCE="9999999",LRPREF="SMALL "
78 S LRTOP="TEST-TUBE",LRTS(1)="Don't-use",LRTS(2)="this-label"
79 S LRINFW="Patient info field",(LRBARID,LRUID)="0000000000",LRAN="000",I=1,N=1,LRXL=0
80 S (LRURG,LRURG0)=1
81 S LRURGA=$$URGA^LRLABLD(LRURG0)
82 ;
83 D LRBAR^LRLABLD
84 D USE^%ZISUTL("LRLABEL"),@LRLABEL
85 D USE^%ZISUTL("LRHOME")
86 ;
87 K DIR,DIRUT,DTOUT,DUOUT,X,Y
88 W !
89 S DIR(0)="YAO",DIR("A")="Label OK: ",DIR("B")="YES"
90 S DIR("?")="Enter 'YES' if label printed correctly, 'NO' if it did not."
91 D ^DIR
92 I $D(DIRUT) G BD
93 I Y=1 G K
94 ;
95 K DIR,DIRUT,DTOUT,DUOUT,X,Y
96 W !
97 S DIR(0)="YAO",DIR("A")="Test printer again: ",DIR("B")="YES"
98 S DIR("?")="Enter 'YES' to test label printing, 'NO' to quit testing."
99 D ^DIR
100 I $D(DIRUT) G BD
101 I Y=1 G T
102 G K
103 ;
104BD ; Bad device - abort, timeout, unsuccessful selection
105 K LRLABLIO
106K ; Close devices
107 D CLOSE^%ZISUTL("LRLABEL")
108 D CLOSE^%ZISUTL("LRHOME")
109 Q
Note: See TracBrowser for help on using the repository browser.