source: ccr/trunk/p/C0CVORU.m@ 550

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

lab rpms extract routines
File size: 8.5 KB
Line 
1C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
3 ;
4EN(LA) ; called from C0CVLAB
5 ; variables
6 ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
7 ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
8 ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
9 ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
10 ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
11 ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
12 ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
13 ; LA("LRDFN") - IEN in LAB DATA file (#63)
14 ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
15 ; LA("AUTO-INST") - Auto-Instrument
16 ;
17 N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY
18 ;
19 S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")=""
20 I $G(PRIMARY)'="" D
21 . S PRIMARY=$$SITE^VASITE(DT,PRIMARY)
22 . S PRIMARY=$P(PRIMARY,U,3)
23 . S LA("AUTO-INST")="LA7V HOST "_PRIMARY
24 ;
25 I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q
26 . ; need to add error logging when no entry in 63.
27 ;
28 ; Get zeroth node of entry in #63.
29 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
30 S LA7NLT=$G(LA("NLT"))
31 ;
32 S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
33 S LA7NTESN=0
34 D ORC
35 ;
36 I $G(LA("SUB"))="CH" D CH
37 ;I $G(LA("SUB"))="MI" D MI^LA7VORU1
38 ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2
39 Q
40 ;
41 ;
42CH ; Build segments for "CH" subscript
43 ;
44 D OBR
45 D NTE
46 S LA7OBXSN=0
47 D OBX
48 ;
49 Q
50 ;
51 ;
52ORC ; Build ORC segment
53 ;
54 N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC
55 ;
56 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
57 ;
58 S ORC(0)="ORC"
59 ;
60 ; Order control
61 S ORC(1)=$$ORC1^LA7VORC("RE")
62 ;
63 ; Remote UID
64 S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH)
65 ;
66 ; Host UID
67 S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH)
68 ;
69 ; Return shipping manifest if found
70 S LA7SM="",LA7696=0
71 I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0))
72 I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
73 I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
74 ;
75 ; Order status
76 ; DoD/CHCS requires ORC-5 valued otherwise will not process message
77 I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
78 ;
79 ; Ordering provider
80 S (LA7X,LA7Y)=""
81 ; "CH" subscript stores requesting provider and requesting div/location.
82 I LA("SUB")="CH" D
83 . N LA7J
84 . S LA7J=$P(LA763(0),"^",13)
85 . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
86 . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
87 . S LA7X=$P(LA763(0),"^",10)
88 ;
89 ; Other subscripts only store requesting provider
90 I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
91 ; Get default institution from MailMan Site Parameters file
92 I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
93 S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
94 ;
95 ; Entering organization
96 S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
97 ;
98 D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
99 D FILESEG^LA7VHLU(GBL,.LA7DATA)
100 ;
101 ; Check for flag to only build message but do not file
102 I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA)
103 ;
104 Q
105 ;
106 ;
107OBR ;Observation Request segment for Lab Order
108 ;
109 N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR
110 ;
111 ; Retrieve placer's OBR information stored in #69.6
112 D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
113 ;
114 ; Initialize OBR segment
115 S OBR(0)="OBR"
116 S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
117 ;
118 ; Remote UID
119 S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH)
120 ;
121 ; Host UID
122 S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH)
123 ;
124 ; Universal service ID, build from info stored in #69.6
125 S LA7X=""
126 I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
127 E S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH)
128 ;
129 ; Collection D/T
130 S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U))
131 ;
132 ; Specimen action code
133 ; If no OBR from PENDING ORDER file (#69.6) then assume added test.
134 I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A")
135 ;
136 ; Infection Warning
137 S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
138 ;
139 ; Lab Arrival Time
140 ; "CH" subscript does not store lab arrival time, use collection time.
141 ; Other subscripts do store lab arrival time (date/time received).
142 I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
143 I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^"))
144 ;
145 ; Specimen source
146 S (LA761,LA762)=""
147 I "CHMI"[LA("SUB") D
148 . S LA761=$P(LA763(0),U,5)
149 . I LA761="" D CREATE^LA7LOG(27)
150 . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11)
151 S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH)
152 ;
153 ; Ordering provider
154 S (LA7X,LA7Y)=""
155 ; "CH" subscript stores requesting provider and requesting div/location.
156 I LA("SUB")="CH" D
157 . N LA7J
158 . S LA7J=$P(LA763(0),"^",13)
159 . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
160 . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
161 . S LA7X=$P(LA763(0),"^",10)
162 ;
163 ; Other subscripts only store requesting provider
164 I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
165 ; Get default institution from MailMan Site Parameters file
166 I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
167 S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
168 ;
169 ; Placer Field #1 (remote auto-inst)
170 ; Build from info stored in #69.6
171 I $G(LA7PLOBR("OBR-18"))'="" D
172 . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH)
173 ; Else build "auto instrument" if sending to VA facility
174 I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D
175 . N LA7X
176 . S LA7X(1)=LA("AUTO-INST")
177 . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
178 ;
179 ; Placer Field #2
180 I $G(LA7PLOBR("OBR-19"))'="" D
181 . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH)
182 ; Else build collecting UID if sending to VA facility
183 I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D
184 . K LA7X
185 . S LA7X(7)=LA("RUID")
186 . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
187 ;
188 ; Filler Field #1
189 ; Send file #63 ien info - used by HDR to track patient/specimen
190 K LA7X
191 S LA7X(1)=LA("LRDFN")
192 S LA7X(2)=LA("SUB")
193 S LA7X(3)=LA("LRIDT")
194 S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
195 ;
196 ; Date Report Completed
197 I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3))
198 ;
199 ; Diagnostic service id
200 S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB))
201 ;
202 ; Parent Result and Parent
203 I $D(LA7PARNT) D
204 . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
205 . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
206 ;
207 ; Principle result interpreter
208 ; Get default institution from MailMan Site Parameters file
209 I "CYEMMISP"[LA("SUB") D
210 . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4)
211 . E S LA7X=$P(LA763(0),"^",2)
212 . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
213 . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
214 ;
215 ; Assistant result interpreter
216 ; Get default institution from MailMan Site Parameters file
217 I "EMSP"[LA("SUB") D
218 . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
219 . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
220 ;
221 ; Technician
222 ; Get default institution from MailMan Site Parameters file
223 I "CYEM"[LA("SUB") D
224 . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
225 . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
226 ;
227 ; Typist - VistA stores as free text
228 ; Get default institution from MailMan Site Parameters file
229 I "CYEMSP"[LA("SUB") D
230 . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
231 . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
232 ;
233 D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
234 D FILESEG^LA7VHLU(GBL,.LA7DATA)
235 ;
236 ; Check for flag to only build message but do not file
237 I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
238 ;
239 Q
240 ;
241 ;
242OBX ;Observation/Result segment for Lab Results
243 ;
244 N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X
245 ;
246 S LA7VTIEN=0
247 F S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN D
248 . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2)
249 . ; Build OBX segment
250 . K LA7DATA
251 . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF))
252 . ; If OBX failed to build then don't store
253 . I '$D(LA7DATA) Q
254 . ;
255 . D FILESEG^LA7VHLU(GBL,.LA7DATA)
256 . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
257 . ;
258 . ; Send performing lab comment and interpretation from file #60
259 . S LA7NTESN=0
260 . I LA7NVAF=1 D PLC^LA7VORUA
261 . D INTRP^LA7VORUA
262 . ;
263 . ; Mark result as sent - set to 1, if corrected results set to 2
264 . I LA("SUB")="CH" D
265 . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q
266 . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1)
267 ;
268 Q
269 ;
270 ;
271NTE ; Build NTE segment
272 ;
273 D NTE^LA7VORUA
274 Q
Note: See TracBrowser for help on using the repository browser.