source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VHLU.m@ 635

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1LA7VHLU ;DALOI/JMC - HL7 segment builder utility ; 11-25-1998
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,62,64**;Sep 27, 1994
3 ;
4 ; Reference to PROTOCOL file (#101) supported by DBIA #872
5 ;
6STARTMSG(LA7EVNT,LA76249) ; Create/initialize HL message
7 ;
8 ; Call with LA7EVNT = Lab event protocol in file (#101)
9 ; LA76249 = if entry already exists, do not create new entry
10 ;
11 N LA7MSH,X
12 ;
13 S LA76249=+$G(LA76249)
14 D INITHL(LA7EVNT)
15 I LA76249<1 S LA76249=$$INIT6249^LA7VHLU
16 I $G(HL) D Q
17 . N LA7X
18 . S LA7X(1)=LA76249,LA7X(2)=$TR(HL,"^","-")
19 . D CREATE^LA7LOG(28)
20 S X="MSH"_LA7FS_LA7ECH_LA7FS_HL("SAN")_LA7FS_HL("SAF")_LA7FS
21 S $P(X,LA7FS,9)=HL("MTN")_$E(LA7ECH,1)_HL("ETN")
22 S $P(X,LA7FS,11)=HL("PID")
23 S $P(X,LA7FS,12)=HL("VER")
24 S:$D(HL("ACAT")) $P(X,LA7FS,15)=HL("ACAT")
25 S:$D(HL("APAT")) $P(X,LA7FS,16)=HL("APAT")
26 S LA7MSH(0)=X
27 D FILE6249^LA7VHLU(LA76249,.LA7MSH)
28 ;
29 Q
30 ;
31INITHL(LA7EVNT) ; Initialize HL environment
32 ;
33 ; Call with LA7EVNT = Lab event protocol in file (#101)
34 ; HL7 v1.6 interface
35 ; LA7101 - IEN of event protocol
36 ; HL - array of output parameters
37 ; INT - DHCP-to-DHCP only
38 ;
39 K ^TMP("HLS",$J)
40 K HL,HLCOMP,HLSUB,HLFS,HLERR,HLMID
41 ;
42 S LA7101=$O(^ORD(101,"B",LA7EVNT,0))
43 D INIT^HLFNC2(LA7101,.HL,0)
44 S (LA7FS,HLFS)=$G(HL("FS"))
45 S (LA7ECH,HLECH)=$G(HL("ECH"))
46 S HLCOMP=$E($G(HL("ECH")),1)
47 S HLSUB=$E($G(HL("ECH")),4)
48 Q
49 ;
50 ;
51GEN ; Generate HL7 v1.6 message
52 ; LA7101 - IEN of event protocol
53 ; HLARYTYP - array type
54 ; HLFORMAT - HLMA formatted/not formatted
55 ; HLMTIEN - IEN in 772 (batch messages)
56 ; HLRESLT = message ID^error code^error description
57 ; HLP("CONTPTR") - continuation pointer field value
58 ; HLP("PRIORITY") - priority field value
59 ; HLP("NAMESPACE") - package namespace
60 ;
61 N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLRESLT,I
62 S HLEID=LA7101,HLARYTYP="GM",HLFORMAT=1,HLMTIEN="",HLRESLT=""
63 S HLP("NAMESPACE")="LA"
64 D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP)
65 K LA7MID M LA7MID=HLRESLT
66 I $P(HLRESLT,"^",2)'="" D CREATE^LA7LOG(23)
67 I $O(LA7MID(0)) D
68 . S I=0
69 . F S I=$O(LA7MID(I)) Q:'I I $L($P(LA7MID,"^",2)) S HLRESLT=LA7MID(I) D CREATE^LA7LOG(23)
70 K HLP
71 Q
72 ;
73 ;
74BUILDSEG(LA7ARRAY,LA7DATA,LA7FS) ; Build HL segment
75 ; Call with LA7ARRAY = array containing fields to build into a segment,
76 ; passed by reference.
77 ; LA7DATA = array used to build segment, pass by reference
78 ; used to return built segment.
79 ; LA7FS = HL field separator
80 ;
81 ; Returns LA7DATA = array with segment built
82 ; LA7DATA(0) = if everything fits on one node
83 ; LA7DATA(0,1...) = multiple elements if >245 characters
84 ;
85 N LA7I,LA7J,LA7LAST,LA7SUB
86 ;
87 K LA7DATA
88 ;
89 S LA7FS=$G(LA7FS)
90 ;
91 ; Node to store data in array
92 S LA7SUB=0
93 ;
94 ; Last element in array
95 S LA7LAST=$O(LA7ARRAY(""),-1)
96 ;
97 F LA7I=0:1:LA7LAST D
98 . I ($L($G(LA7DATA(LA7SUB)))+$L($G(LA7ARRAY(LA7I))))>245 S LA7SUB=LA7SUB+1
99 . I $O(LA7ARRAY(LA7I,""))'="" D
100 . . S LA7J=""
101 . . F S LA7J=$O(LA7ARRAY(LA7I,LA7J)) Q:LA7J="" D
102 . . . I ($L($G(LA7DATA(LA7SUB)))+$L($G(LA7ARRAY(LA7I,LA7J))))>245 S LA7SUB=LA7SUB+1
103 . . . S LA7DATA(LA7SUB)=$G(LA7DATA(LA7SUB))_$G(LA7ARRAY(LA7I,LA7J))
104 . S LA7DATA(LA7SUB)=$G(LA7DATA(LA7SUB))_$G(LA7ARRAY(LA7I))_LA7FS
105 Q
106 ;
107 ;
108FILESEG(LA7ROOT,LA7DATA) ; File HL segment in global
109 ; Call with LA7ROOT = global root used to store HL segment
110 ; LA7DATA = array with data to file (pass by reference)
111 ;
112 N LA7HLSN,LA7I
113 I $G(LA7ROOT)="" Q ; no global root passed.
114 ;
115 ; get next subscript number
116 S LA7HLSN=($O(@(LA7ROOT)@(""),-1))+1
117 ;
118 ; store first 245 characters of segment
119 S @LA7ROOT@(LA7HLSN)=$G(LA7DATA(0))
120 ;
121 ; if segment >245 characters then store rest of message
122 S LA7I=0
123 F S LA7I=$O(LA7DATA(LA7I)) Q:LA7I="" S @LA7ROOT@(LA7HLSN,LA7I)=LA7DATA(LA7I)
124 ;
125 Q
126 ;
127 ;
128INIT6249() ; Create stub entry in file #62.49
129 ; Returns ien of entry in #62.49 that was created
130 ; NOTE: set lock on entry in #62.49, does not release it.
131 ; calling process should release lock
132 ;
133 N LA7ERR,LA7FDA,LA7IEN,X,Y
134 ;
135 ; Lock zeroth node of file.
136 L +^LAHM(62.49,0):99999
137 I '$T Q -1
138 ;
139 F LA76249=$P(^LAHM(62.49,0),"^",3):1 Q:'$D(^LAHM(62.49,LA76249))
140 ; Lock entry in file 62.49 - Calling process is responsible for releasing
141 ; lock when no longer needed.
142 L +^LAHM(62.49,LA76249):99999
143 I '$T Q -1
144 ;
145 S LA7DT=$$NOW^XLFDT
146 S LA7FDA(1,62.49,"+1,",.01)=LA76249 ; message number
147 S LA7FDA(1,62.49,"+1,",2)="B" ; status =(B)uilding
148 S LA7FDA(1,62.49,"+1,",4)=LA7DT ; Date/time entered
149 S LA7IEN(1)=LA76249
150 D UPDATE^DIE("S","LA7FDA(1)","LA7IEN","LA7ERR")
151 I $D(LA7ERR) S LA76249=-1
152 ;
153 ; Unlock zero node
154 L -^LAHM(62.49,0)
155 Q LA76249
156 ;
157 ;
158FILE6249(LA76249,LA7DATA) ; File HL segment in LAHM(62.49) global
159 ; Call with LA76249 = ien of entry in file # 62.49
160 ; LA7DATA = array with data to file (pass by reference)
161 ;
162 N LA7I,LA7J,LA7WP
163 I '$G(LA76249) Q ; no entry passed.
164 ;
165 ; move data in positive number subscripts
166 S LA7I="",LA7J=0
167 F S LA7I=$O(LA7DATA(LA7I)) Q:LA7I="" D
168 . S LA7J=LA7J+1
169 . S LA7WP(LA7J)=LA7DATA(LA7I)
170 ;
171 ; set blank line which separates each segment
172 S LA7WP(LA7J+1)=""
173 ;
174 ; file data
175 D WP^DIE(62.49,LA76249_",",150,"A","LA7WP")
176 Q
177 ;
178 ;
179P(LA7X,LA7P,LA7EC) ; get field LA7P from array (passed by ref.)
180 ; Call with LA7X = array to extract data from, pass by reference.
181 ; LA7P = field to extract
182 ; LA7EC = encoding character separator
183 ;
184 ; Returns LA7Y = value of requested piece
185 ;
186 N I,L,LA7Y,L1,Y
187 S L=0,Y=1,LA7Y=""
188 ;Y=begining piece of each node, L1=number of pieces in each node
189 ;L=last piece in each node, quit when last piece is greater than LA7P
190 F I=0:1 Q:'$D(LA7X(I)) S L1=$L(LA7X(I),LA7EC),L=L1+Y-1 D Q:Y>LA7P
191 . ;if LA7P is less than last piece, this node has field you want
192 . S:LA7P'>L LA7Y=LA7Y_$P(LA7X(I),LA7EC,(LA7P-Y+1))
193 . S Y=L
194 Q LA7Y
195 ;
196 ;
197PA(LA7X,LA7P,LA7EC,LA7Y) ; get field LA7P from array (passed by ref.)
198 ; Call with LA7X = array to extract data from, pass by reference.
199 ; LA7P = field to extract
200 ; LA7EC = encoding character separator
201 ;
202 ; Returns LA7Y = array value of requested piece (returned by reference)
203 ;
204 N I,L,L1,X,Y
205 S (L,LA7Y)=0,Y=1
206 ;Y=begining piece of each node, L1=number of pieces in each node
207 ;L=last piece in each node, quit when last piece is greater than LA7P
208 F I=0:1 Q:'$D(LA7X(I)) S L1=$L(LA7X(I),LA7EC),L=L1+Y-1 D Q:Y>LA7P
209 . ;if LA7P is less than last piece, this node has field you want
210 . I LA7P'>L S X=$P(LA7X(I),LA7EC,(LA7P-Y+1)) S:X]"" LA7Y=LA7Y+1,LA7Y(LA7Y)=X
211 . S Y=L
212 Q
213 ;
214 ;
215BLG(LA7ACTN,LA7CHGTY,LA7FS,LA7ECH) ; Build BLG segment - billing information
216 ; Call with LA7ACTN = billing account Number
217 ; LA7CHGTY = charge type
218 ; LA7ECH = HL encoding characters
219 ;
220 ; Returns LA7Y
221 ;
222 ; Default to CO (contract) for charge type - table 0122
223 S LA7CHGTY=$G(LA7CHGTY,"CO")
224 S LA7Y="BLG"_LA7FS_LA7FS_LA7CHGTY_LA7FS_$$M11^HLFNC(LA7ACTN,LA7ECH)_LA7FS
225 Q LA7Y
226 ;
227 ;
228PTEXTID(LA74,LA7UID,LA7Y) ; Retrieve patient's id that was transmitted by other system.
229 ; Used to build PID-2 when returning results to placer.
230 ; Looks in file LAB PENDING ORDERS (#69.6) for info pertaining to placer's order.
231 ; Call with LA74 = ien of placer in INSTITUTION file (#4)
232 ; LA7UID = placer's specimen identifier (UID, etc.)
233 ;
234 ; Returns array LA7Y by reference
235 ; LA7Y("FS") - original field separator
236 ; LA7Y("ECH") - original encoding characters used
237 ; LA7Y("PID-2") - original PID-2 sequence
238 ; LA7Y("PID-4") - original PID-4 sequence
239 ;
240 N LA7696,LA7X
241 ;
242 S LA74=$G(LA74),LA7UID=$G(LA7UID),LA7Y=""
243 ;
244 ; Return null if no values passed
245 I LA74<1!(LA7UID="") Q
246 ;
247 S LA7696=$O(^LRO(69.6,"RST",LA74,LA7UID,0))
248 I LA7696 D
249 . S LA7X=$G(^LRO(69.6,LA7696,700))
250 . S LA7Y("FS")=$E(LA7X,1)
251 . S LA7Y("ECH")=$E(LA7X,2,5)
252 . S LA7Y("PID-2")=$G(^LRO(69.6,LA7696,700.02))
253 . S LA7Y("PID-4")=$G(^LRO(69.6,LA7696,700.04))
254 Q
255 ;
256 ;
257RETOBR(LA74,LA7UID,LA7NLT,LA7Y) ; Retrieve placer's various OBR's that were transmitted by other system.
258 ; Used to build OBR-4/17/18 when returning results to placer.
259 ; Looks in file LAB PENDING ORDERS (#69.6) for info pertaining to placer's order.
260 ;
261 ; Call with LA74 = ien of placer in INSTITUTION file (#4)
262 ; LA7UID = placer's specimen identifier (UID, accession number, etc.)
263 ; LA7NLT = ordered NLT test code
264 ;
265 ; Returns array LA7Y by reference
266 ; LA7Y("FS") - original field separator
267 ; LA7Y("ECH") - original encoding characters used
268 ; LA7Y("OBR-4") - original OBR-4 sequence
269 ; LA7Y("OBR-18") - original OBR-18 sequence
270 ; LA7Y("OBR-19") - original OBR-19 sequence
271 ;
272 N LA7696,LA76964,LA7X
273 ;
274 S LA74=$G(LA74),LA7UID=$G(LA7UID),LA7Y=""
275 ;
276 ; Return null if no values passed
277 I LA74<1!(LA7UID="")!(LA7NLT="") Q
278 ;
279 S LA7696=$O(^LRO(69.6,"RST",LA74,LA7UID,0))
280 I LA7696<1 Q
281 ;
282 S LA7X=$G(^LRO(69.6,LA7696,700))
283 S LA7Y("FS")=$E(LA7X,1)
284 S LA7Y("ECH")=$E(LA7X,2,5)
285 ;
286 S LA76964=$O(^LRO(69.6,LA7696,2,"C",LA7NLT,0))
287 I LA76964<1 Q
288 ;
289 S LA7Y("OBR-4")=$G(^LRO(69.6,LA7696,2,LA76964,700.04))
290 S LA7Y("OBR-18")=$G(^LRO(69.6,LA7696,2,LA76964,700.18))
291 S LA7Y("OBR-19")=$G(^LRO(69.6,LA7696,2,LA76964,700.19))
292 ;
293 Q
Note: See TracBrowser for help on using the repository browser.