source: WorldVistAEHR/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN2.m@ 1638

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

initial load of WorldVistAEHR
File size: 9.2 KB
Line 
1LA7VIN2 ;DALOI/JMC - Process Incoming UI Msgs, continued ; 01/14/99
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 1994
3 ;This routine is a continuation of LA7VIN1 and is only called from there.
4 Q
5 ;
6MSH ; Process MSH segment
7 N LA7X
8 ;
9 I $E(LA7SEG(0),1,3)'="MSH" D Q
10 . S (LA7ABORT,LA7ERR)=7
11 . D CREATE^LA7LOG(LA7ERR)
12 ;
13 ; Encoding characters
14 S LA7FS=$E(LA7SEG(0),4)
15 S LA7CS=$E(LA7SEG(0),5)
16 S LA7ECH=$E(LA7SEG(0),5,8)
17 ; No field or component seperator
18 I LA7FS=""!(LA7CS="") D
19 . S (LA7ABORT,LA7ERR)=8
20 . D CREATE^LA7LOG(LA7ERR)
21 ;
22 ; Sending application
23 S LA7SAP=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
24 S LA7ID=LA7SAP_"-I-"
25 ;
26 ; Sending facility
27 S LA7SFAC=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
28 ;
29 ; Receiving application
30 S LA7RAP=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
31 ;
32 ; Receiving facility
33 S LA7RFAC=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
34 ;
35 ; Message date/time from first component
36 S LA7MEDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,7,LA7FS),LA7CS),"L")
37 ;
38 ; Message type
39 S LA7X=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
40 S LA7MTYP=$P(LA7X,LA7CS,1)
41 ;
42 ; Message Control ID
43 S LA7MID=$$P^LA7VHLU(.LA7SEG,10,LA7FS)
44 ;
45 ; HL7 version
46 S LA7X=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
47 S LA7HLV=$P(LA7X,LA7CS,1)
48 Q
49 ;
50 ;
51ORC ; Process ORC segment
52 N LA7X,LA7Y
53 ;
54 ; Order control
55 S LA7OTYPE=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
56 ;
57 ; Place order number
58 S LA7PON=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
59 ;
60 ; Setup shipping manifest variable
61 S LA7Y=0
62 S LA7X=$P($$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7CS)
63 I LA7X'="" S LA7Y=$O(^LAHM(62.8,"B",LA7X,0))
64 I LA7Y S LA7628=LA7Y
65 S LA7SM=LA7Y_"^"_LA7X
66 ;
67 ; Setup shipping configuration variable
68 I $P(LA7SM,"^") S LA7629=+$P($G(^LAHM(62.8,$P(LA7SM,"^"),0)),"^",2)
69 E S LA7629=0
70 ;
71 ; Set new order/shipping mainfest received alert/identifiers
72 I LA7MTYP="ORM",$L($P(LA7SM,"^",2)) D
73 . S ^TMP("LA7-ORM",$J,LA76248,LA76249,$P(LA7SM,"^",2))=""
74 . D SETID^LA7VHLU1(LA76249,LA7ID,$P(LA7SM,"^",2))
75 ;
76 ; Order quantity/timing (duration, units, urgency)
77 S LA7ODUR=$P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,3)
78 S LA7ODURU=$P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,4)
79 S LA7OUR=$P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,6)
80 ;
81 ; Date/time of transaction
82 S LA7ORDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,10,LA7FS),LA7CS),"L")
83 ;
84 ; Placer's entered by (id^duz^last name, first name, mi [id])
85 S LA7X=$$P^LA7VHLU(.LA7SEG,11,LA7FS)
86 S LA7PEB=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
87 I LA7PEB="^^" S LA7PEB=""
88 ;
89 ; Placer's verified by (id^duz^last name, first name, mi [id])
90 S LA7X=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
91 S LA7PVB=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
92 I LA7PVB="^^" S LA7PVB=""
93 ;
94 ; Placer's ordering provider (id^duz^last name, first name, mi [id])
95 S LA7X=$$P^LA7VHLU(.LA7SEG,13,LA7FS)
96 S LA7POP=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
97 I LA7POP="^^" S LA7POP=""
98 ;
99 ; Enterer's ordering location
100 S LA7X=$$P^LA7VHLU(.LA7SEG,14,LA7FS)
101 S LA7Y=$$PLTFM^LA7VHLU4(LA7X,LA7ECH)
102 S LA7EOL=$P(LA7Y,"^",1,3)
103 I LA7EOL="^^" S LA7EOL=""
104 ;
105 ; Order control code reason
106 S LA7OCR=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
107 ;
108 ;
109 ; If ORM order message, determine specimen collecting site from ORC
110 ; segment, if none use MSH sending facility value
111 S LA7CSITE=""
112 I LA7MTYP="ORM" D
113 . S LA7X=$P($$P^LA7VHLU(.LA7SEG,18,LA7FS),LA7CS)
114 . S LA7CSITE=$$FINDSITE^LA7VHLU2(LA7X,2,1)
115 . I LA7CSITE'>0 S LA7CSITE=$$FINDSITE^LA7VHLU2(LA7SFAC,2,0)
116 ;
117 Q
118 ;
119 ;
120NTE ; Process NTE segment
121 ; NTE segments contain comments from instruments or other facilities.
122 ; NTE segments following OBR's contain comments which refer to the entire test battery.
123 ; NTE segments following OBX's contain comments which are test specific.
124 ;
125 ; For comments in ORU messages:
126 ; Test specific comments can be prefaced with a site defined prefix -
127 ; see field REMARK PREFIX (#19) in CHEM TEST multiple of AUTOMATED INSTRUMENT (#62.4 file.
128 ; There can be more than one NTE, each will be stored as a comment in ^LAH.
129 ;
130 N LA7,LA7I,LA7NTE,LA7SOC
131 ;
132 S LA7SOC=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
133 S LA7NTE=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
134 ;
135 ; Trim trailing spaces.
136 I LA7NTE'="" S LA7NTE=$$TRIM^XLFSTR(LA7NTE,"R"," ")
137 I LA7NTE="" S LA7NTE=" "
138 ;
139 I LA7MTYP="ORM" D OCOM Q
140 ;
141 ; Check for repeating comments in NTE segment and process
142 ; If "^" in remark then translate to "~" to store.
143 F LA7I=1:1:$L(LA7NTE,$E(LA7ECH,2)) D
144 . S LA7RMK=$P(LA7NTE,$E(LA7ECH,2),LA7I)
145 . I LA7RMK="" Q
146 . S LA7RMK=$$UNESC^LA7VHLU3(LA7RMK,LA7FS_LA7ECH)
147 . I LA7RMK["^" S LA7RMK=$TR(LA7RMK,"^","~")
148 . I LA7MTYP="ORU" D RCOM Q
149 . I LA7MTYP="ORR",$G(LA7OTYPE)="UA" D RCOM Q
150 ;
151 Q
152 ;
153 ;
154PID ; Process PID segment
155 N LA7X,LA7Y,X,Y
156 ;
157 S (DFN,LA7DOB,LA7ICN,LA7PRACE,LA7PNM,LA7PTID2,LA7PTID3,LA7PTID4,LA7SEX,LA7SSN,LRDFN,LRTDFN)=""
158 ;
159 ; PID Set ID
160 S LA7SPID=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
161 ;
162 ; Extract patient identifiers
163 S LA7PTID2=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
164 S LA7PTID3=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
165 S LA7PTID4=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
166 ; Resolve ICN if identifier is from MPI
167 ; Assume SSN is identifier is "SS" or blank
168 F I=1:1:$L(LA7PTID3,$E(LA7ECH,2)) D
169 . N J,LA7X,LA7ID
170 . S X=$P(LA7PTID3,$E(LA7ECH,2),I) Q:'$L(X)
171 . S LA7PTID3(I)=X,LA7ID=$P(LA7PTID3(I),$E(LA7ECH),5)
172 . I LA7ID'="","NI^PI"[LA7ID D Q
173 . . S Y=$P(LA7PTID3(I),$E(LA7ECH))
174 . . I Y?10N1"V"6N S LA7Y=Y
175 . . E S LA7Y=Y_"V"_$P(LA7PTID3(I),$E(LA7ECH),2)
176 . . S LA7X=$$CHKICN^LA7VHLU2(LA7Y)
177 . . I LA7X>0 S DFN=$P(LA7X,"^"),LA7ICN=$P(LA7X,"^",2)
178 . I LA7ID="SS"!(LA7ID="") D Q
179 . . F J=1:1:3 S LA7X(J)=$P(LA7PTID3(I),$E(LA7ECH),J)
180 . . I LA7X(1)'?9N.1A Q
181 . . I LA7X(3)="M11",LA7X(2)'=$P($$M11^HLFNC(LA7X(1),LA7ECH),$E(LA7ECH),2) Q
182 . . S LA7SSN=LA7X(1),DFN=$O(^DPT("SSN",LA7SSN,0))
183 ;
184 ; Check PID-2 (alternate patient id) if PID-3 did not yield SSN/ICN
185 F I=1:1:$L(LA7PTID2,$E(LA7ECH,2)) D
186 . N J,LA7X,LA7ID
187 . S X=$P(LA7PTID2,$E(LA7ECH,2),I) Q:'$L(X)
188 . S LA7PTID2(I)=X,LA7ID=$P(LA7PTID2(I),$E(LA7ECH),5)
189 . I LA7ICN="",LA7ID'="","NI^PI"[LA7ID D Q
190 . . S Y=$P(LA7PTID2(I),$E(LA7ECH))
191 . . I Y?10N1"V"6N S LA7Y=Y
192 . . E S LA7Y=Y_"V"_$P(LA7PTID2(I),$E(LA7ECH),2)
193 . . S LA7X=$$CHKICN^LA7VHLU2(LA7Y)
194 . . I LA7X>0 S DFN=$P(LA7X,"^"),LA7ICN=$P(LA7X,"^",2)
195 . I LA7SSN="",LA7ID="SS"!(LA7ID="") D Q
196 . . F J=1:1:3 S LA7X(J)=$P(LA7PTID2(I),$E(LA7ECH),J)
197 . . I LA7X(1)'?9N.1A Q
198 . . I LA7X(3)="M11",LA7X(2)'=$P($$M11^HLFNC(LA7X(1),LA7ECH),$E(LA7ECH),2) Q
199 . . S LA7SSN=LA7X(1),DFN=$O(^DPT("SSN",LA7SSN,0))
200 ;
201 ; Extract patient name
202 S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
203 I LA7X'="" S LA7PNM=$$FMNAME^HLFNC(LA7X,LA7ECH)
204 ;
205 ; Extract date of birth
206 ; Check for degree of precision in 2nd component to provide backward compatibility with HL7 <v2.3
207 S LA7X=$$P^LA7VHLU(.LA7SEG,8,LA7FS)
208 I LA7X D
209 . S LA7Y=$P(LA7X,LA7CS,2),LA7X=$P(LA7X,LA7CS,1)
210 . I (LA7Y=""!(LA7Y="D")),$E(LA7X,9,12)="0000" S LA7X=$E(LA7X,1,8)
211 . S LA7DOB=$$HL7TFM^XLFDT(LA7X)
212 . I LA7DOB<1 S LA7DOB=""
213 . I LA7Y="L" S LA7DOB=$E(LA7DOB,1,5)_"00"
214 . I LA7Y="Y" S LA7DOB=$E(LA7DOB,1,3)_"0000"
215 ;
216 ; Extract patient's sex
217 S LA7SEX=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
218 ;
219 ; Extract patient's race
220 S LA7X=$$P^LA7VHLU(.LA7SEG,11,LA7FS)
221 I $P(LA7X,LA7CS)'="" D
222 . I $P(LA7X,LA7CS,3)="0005" S $P(LA7X,LA7CS,3)="HL70005"
223 . S LA7PRACE=$P(LA7X,LA7CS)_":"_$P(LA7X,LA7CS,2)_$S($P(LA7X,LA7CS,3)'="":":"_$P(LA7X,LA7CS,3),1:"")
224 ;
225 ; Extract patient's SSN and determine DFN
226 ; If SSN determined previously from PID-3 then compare SSN's
227 ; If DFN determined previously from ICN then check DFN based on SSN.
228 S LA7X=$P($$P^LA7VHLU(.LA7SEG,20,LA7FS),LA7CS)
229 S LA7X=$TR(LA7X,"-","") ; remove "-" if any
230 I LA7X?9N.1A D
231 . I LA7SSN'="",LA7X'=LA7SSN Q
232 . S LA7SSN=LA7X
233 . I DFN,DFN'=$O(^DPT("SSN",LA7SSN,0)) Q
234 . S DFN=$O(^DPT("SSN",LA7SSN,0))
235 I DFN D
236 . S LRDFN=$P($G(^DPT(DFN,"LR")),"^")
237 . S LRTDFN=$P($G(^DPT(DFN,"LRT")),"^")
238 ;
239 Q
240 ;
241 ;
242PV1 ; Process PV1 segment
243 ;
244 ; PV1 Set ID
245 S LA7SPV1=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
246 ;
247 ; Extract ordering location
248 S LA7LOC=$P($$P^LA7VHLU(.LA7SEG,4,LA7FS),LA7CS)
249 Q
250 ;
251 ;
252RCOM ; Store result comments in ORU messages
253 ;
254 ; Don't store remark if same as specimen comment (without "~").
255 I $G(LA7AA),$G(LA7AD),$G(LA7AN),LA7RMK=$TR($P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3)),"^",6),"~") Q
256 ; Or patient info (#.091 in file 63) - info previously downloaded
257 I $G(LA7AA),$G(LA7AD),$G(LA7AN),LA7RMK=$G(^LR(+$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),.091)) Q
258 ;
259 ; If test specific, store comment prefix with comments (see LA7VIN5)
260 I $O(LA7RMK(0,0)) D Q
261 . N LA7I
262 . S LA7I=0
263 . F S LA7I=$O(LA7RMK(0,LA7I)) Q:'LA7I D
264 . . I '$P(LA7RMK(0,LA7I),"^") Q
265 . . ; Don't store if status not "FINAL"
266 . . I $P(LA7RMK(0,LA7I),"^")=2,"CFU"'[$G(LA7ORS) Q
267 . . D RMKSET^LASET(LA7LWL,LA7ISQN,LA7RMK,$P(LA7RMK(0,LA7I),"^",2))
268 ;
269 ; Store comment in 1 node of ^LAH global
270 I $P(LA7624(0),"^",17) D RMKSET^LASET(LA7LWL,LA7ISQN,LA7RMK,"")
271 K LA7RMK
272 Q
273 ;
274 ;
275OCOM ; Store order comments from ORM messages in file #69.6
276 ; Check for repeating comments in NTE segment and process
277 ; If "^" in remark then translate to "~" to store.
278 ;
279 ; If source of comment (LA7SOC) is "RQ" then comment is from CHCS which
280 ; uses a composite data type for NTE-3. VistA only extracts component #9
281 ; which contains the external value of the comment.
282 ;
283 N LA7DIE,LA7RMK,LA7WP,X
284 I $G(LA7696)<1 Q
285 F LA7I=1:1:$L(LA7NTE,$E(LA7ECH,2)) D
286 . S LA7RMK=$P(LA7NTE,$E(LA7ECH,2),LA7I)
287 . I LA7SOC="RQ" D
288 . . S X=$P(LA7RMK,$E(LA7ECH),9)
289 . . I X'="" S LA7RMK=X
290 . I LA7RMK="" Q
291 . S LA7RMK=$$UNESC^LA7VHLU3(LA7RMK,LA7FS_LA7ECH)
292 . I LA7RMK["^" S LA7RMK=$TR(LA7RMK,"^","~")
293 . S LA7WP(LA7I,0)=LA7RMK
294 D WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)")
295 Q
Note: See TracBrowser for help on using the repository browser.