source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRLABLD.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1LRLABLD ;DALOI/TGA/JMC - LABELS ON DEMAND ; 5/22/87 20:42
2 ;;5.2;LAB SERVICE;**65,161,218**;Sep 27, 1994
3 ;
4ENT ;
5 ; Called by LROE
6 S U="^"
7 D PSET
8 S LRLABLIO=IO
9 S LRAA=0
10 F S LRAA=$O(LRLBL(LRAA)) Q:LRAA<1 D EN2
11 K LRBAR,LRBAR1,LRBAR0,LRBARID,LREND,LRI,LRN,LROK,LRURG,LRURG0,LRURGA
12 I $D(ZTQUEUED) S ZTREQ="@"
13 E D PKILL^%ZISP
14 Q
15 ;
16EN2 ;
17 D LBLTYP
18 D LRBAR
19 S LRAN=0
20 F S LRAN=$O(LRLBL(LRAA,LRAN)) Q:LRAN<1 D
21 . N LRRB,LRLLOC
22 . S X=LRLBL(LRAA,LRAN),LRSN=+X,LRAD=$P(X,U,2),LRODT=$P(X,U,3),LRRB=$P(X,U,4),LRLLOC=$P(X,U,5),LRACC=$P(X,U,6),LRCE=$P(X,U,7)
23 . D GO
24 Q
25 ;
26GO ; From above, LRLABXT, LRPHLIS1
27 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
28 S LRDAT=$TR($$FMTE^XLFDT($P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U),"2MZ"),"@"," ") ; Date/time with "@" --> " "
29 S LRTJ=$P($G(^LRO(69,LRODT,1,LRSN,0)),U,3)
30 S LRTJDATA=$G(^LAB(62,+LRTJ,0))
31 S LRTOP=$P(LRTJDATA,U,3),S1=$P(LRTJDATA,U,4),S2=$P(LRTJDATA,U,5)
32 I LRTOP="" D
33 . S LRTOP=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
34 . I LRTOP>0 D
35 . . S T=$P($G(^LAB(62,+$P(LRTOP,U,2),0)),U,1)
36 . . S LRTOP=$P($G(^LAB(61,+LRTOP,0)),U,1),LRTOP=T_$S(LRTOP'=T:" "_LRTOP,1:"")
37 . . S LRTJDATA=$G(^LAB(62,+LRTJ,0)),S1=$P(LRTJDATA,U,4),S2=$P(LRTJDATA,U,5)
38 S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
39 S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=$P(^(0),U,2),LRINFW=$P($G(^LR(LRDFN,.091)),U,1)
40 D PT^LRX Q:LREND
41 D UID,BARID
42 K LRTS,LRURG
43 S LRTVOL=0,LRURG0=9,LRXL=0
44 S T=0
45 F S T=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T)) Q:T<1 D
46 . S LRTV=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T,0))
47 . I LRTV,$P(LRTV,U,2)<49 D
48 . . S LRVOL=0
49 . . S:$P(LRTV,U,2)=1 LRURG=1
50 . . I $P(LRTV,U,2),$P(LRTV,U,2)<LRURG0 S LRURG0=$P(LRTV,U,2)
51 . . F LRSSP=0:0 S LRSSP=$O(^LAB(60,+LRTV,3,LRSSP)) Q:LRSSP<1 I LRTJ=+^(LRSSP,0) S LRVOL=$P(^(0),U,4),LRTVOL=LRTVOL+LRVOL
52 . . S LRTS(T)=$P($G(^LAB(60,+LRTV,.1)),U,1)
53 . . S LRXL=LRXL+$P($G(^LAB(60,+LRTV,0)),U,15)
54 S LRN=$S(+S1=0:1,1:LRTVOL\S1+$S(LRTVOL#S1:1,LRTVOL=0:1,1:0))+LRXL
55 Q:LRN<1
56 S LRURGA=$$URGA(LRURG0)
57 F LRI=1:1:LRN D
58 . S I=LRI,N=LRN ; Label routines use "I" and "N"
59 . N LRI,LRN
60 . S LRPREF=$S(S2="":"",LRTVOL>S2:"LARGE ",1:"SMALL "),LRTVOL=LRTVOL-S1
61 . D @LRLABEL
62 D KVA^VADPT
63 Q
64 ;
65UID ; Set up variables for unique id.
66 ; Called by above, LRLABLD0, LRPHLIS1
67 ; LRUID = unique id number of accession
68 I $G(LRAA),$G(LRAD),$G(LRAN) S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") ;Get unique identifier
69 E S LRUID=""
70 Q
71 ;
72BARID ; Set up variables for barcoding
73 ; LRBARID = number to be barcoded on label, based on accession area setup in file #68.
74 ; If no accession # or UID - sets LRBARID=""
75 ; Called by LRLABLD0, LRPHLIS1
76 N LRX
77 S LRX=$G(^LRO(68,+$G(LRAA),.4)) ; Barcode info from accession file.
78 S LRBARID=""
79 I $L($G(LRUID)),$P(LRX,"^",2)="L" S LRBARID=LRUID Q ; Barcode UID
80 I $G(LRAN)>0,LRBARID="" D
81 . S LRBARID=LRAN ; Barcode accession number
82 . I $P(LRX,"^",3) S LRBARID=$$RJ^XLFSTR(LRBARID,$P(LRX,"^",3),"0") ; Pad barcode number
83 Q
84 ;
85LBLTYP ; Determine label routine to use.
86 ; Sets LRLABEL to label print routine (label^routine).
87 ; Called by above, LRLABLD0, LRLABLIO, LRLABXOL, LRLABXT, LRPHLIS1
88 ;
89 N LRLBLDEV
90 ;
91 ; Default label routine
92 S LRLABEL="^LRLABEL"_$P($G(^LAB(69.9,1,3)),U,3)
93 S LRLBLDEV=$O(^LAB(69.9,1,3.6,"B",+$G(IOS),0))
94 I LRLBLDEV D
95 . S LRLBLDEV(0)=$G(^LAB(69.9,1,3.6,LRLBLDEV,0))
96 . ; default accession area for characteristics.
97 . I '$G(LRAA),$P(LRLBLDEV(0),"^",6) S LRAA=$P(LRLBLDEV(0),"^",6)
98 ;
99 ; Site's local accession area label routine.
100 I $G(LRAA)>0,$L($P(^LRO(68,LRAA,.4),"^",5)) D Q
101 . S LRLABEL=$P(^LRO(68,LRAA,.4),"^",4,5)
102 ;
103 ; This device not defined in file #69.9.
104 I LRLBLDEV<1 Q
105 ;
106 ; Site's designated local label routine.
107 I $L($P(LRLBLDEV(0),"^",5)) D Q
108 . S LRLABEL=$P(LRLBLDEV(0),"^",4,5)
109 ;
110 ; Intermec 3000/4000 printer
111 I $P(LRLBLDEV(0),"^",2)=1 D
112 . I $P(LRLBLDEV(0),"^",3)=1 S LRLABEL="^LRLABELC" Q ; 1x3 label
113 . I $P(LRLBLDEV(0),"^",3)=2 S LRLABEL="^LRLABELA" Q ; 1x2 label
114 . I $P(LRLBLDEV(0),"^",3)=3 S LRLABEL="^LRLABELB" Q ; 10 part label
115 ;
116 ; Zebra ZPL II compatible printer
117 I $P(LRLBLDEV(0),"^",2)=2 D
118 . I $P(LRLBLDEV(0),"^",3)=1 S LRLABEL="^LRLABELG" Q ; 1x3 label
119 . I $P(LRLBLDEV(0),"^",3)=2 S LRLABEL="^LRLABELD" Q ; 1x2 label
120 . I $P(LRLBLDEV(0),"^",3)=3 S LRLABEL="^LRLABELE" Q ; 10 part label
121 ;
122 Q
123 ;
124 ;
125PSET ; Setup special printer variables - barcode on/barcode off
126 ; Called by above, LRLABXOL, LRLABXT, LRPHLIS1
127 ;
128 ; Cleanup first
129 D PKILL^%ZISP
130 ;
131 ; Set variables
132 I IOST(0) D PSET^%ZISP
133 ;
134 S LRBAR0=$G(IOBAROFF)
135 S LRBAR1=$G(IOBARON)
136 ;
137 Q
138 ;
139 ;
140URGA(X) ; Determine urgency abbreviation to print on label
141 ; Input X = pointer to Urgency #62.05 file
142 ; Returns Y = urgency abbreviation^display type if turned on
143 ; Called by above, LRLABELF, LRLABLD0, LRLABLIO, LRPHLIS1
144 N Y
145 S Y=""
146 I '$G(X) Q Y
147 S X(0)=$G(^LAB(62.05,X,0))
148 S Y=$P(X(0),"^",7)_"^"_$P(X(0),"^",6)
149 Q Y
150 ;
151LRTXT(LRTLST,LRLEN) ; Parse test list to print on label.
152 ; Builds a string of test names concatentated using ";" to the maximum
153 ; length (LRLEN) specified. Terminates list with "..." if exceeds length
154 ; specified.
155 ; Call with
156 ; LRTLST = array containing name of test to parse
157 ; LRLEN = length of test string to return (default=35)
158 ;
159 ; Returns LRTXT = variable containing concatenated test list.
160 ;
161 ; Called from LRLABEL, LRLABEL1, LRLABEL2, LRLABEL3, LRLABEL5, LRLABEL6,
162 ; LRLABELA, LRLABELB, LRLABELC, LRLABELD, LRLABELE
163 ;
164 N I,J,LRTXT,X,Y
165 I '$G(LRLEN) S LRLEN=35
166 S J=0,LRTXT=""
167 F S J=$O(LRTLST(J)) Q:J<1!($L(LRTXT)>LRLEN) D
168 . S X=LRTLST(J)_$S($O(LRTLST(J)):";",1:"") ; Add ";" if more tests
169 . S LRTXT=LRTXT_X
170 I $L(LRTXT)>LRLEN D
171 . S Y=$L(LRTXT,";")
172 . F I=Y:-1:1 S X=$P(LRTXT,";",1,I) I $L(X)<(LRLEN-2) Q
173 . S LRTXT=$E(X,1,(LRLEN-3))_"..."
174 Q LRTXT
175 ;
176LRBAR ; Setup LRBAR array if barcodes for this accession area
177 ; Called by above, LRLABLD0, LRLABLIO, LRLABXT, LRPHIS1
178 I $G(LRAA)<1 Q ; Pointer not valid.
179 I $P($G(^LRO(68,LRAA,0)),U,15) S LRBAR(LRAA)=+$P($G(^LRO(68,LRAA,0)),U,15)
180 Q
Note: See TracBrowser for help on using the repository browser.