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

Last change on this file since 1731 was 1586, checked in by Sam Habiel, 12 years ago

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