source: WorldVistAEHR/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UIIN1.m@ 1000

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

initial load of WorldVistAEHR

File size: 5.8 KB
Line 
1LA7UIIN1 ;DALOI/JRR - Process Incoming UI Msgs, continued ; 12/3/1997
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,23,27,57,59**;Sep 27, 1994
3 ; This routine is a continuation of LA7UIIN and is only
4 ; called from there. It is called with each message found
5 ; in the incoming queue.
6 ;
7 Q
8 ;
9NXTMSG ;
10 N LA70070,LA7150,LA761,LA762,LA7624,LA762495
11 N LA7AA,LA7AD,LA7ACC,LA7CNT,LA7CS,LA7CUP,LA7ECH,LA7ENTRY,LA7FS,LA7IDE,LA7LWL,LA7MSH,LA7OBR,LA7OBR3,LA7QUIT,LA7TRAY,LA7USID
12 N CUP,IDE,IDENT,ISQN
13 ;
14 S (LA7CNT,LA7QUIT)=0
15 S (LA7AN,LA7INST,LA7OBR,LA7UID)=""
16 S DT=$$DT^XLFDT
17 ; Message built but no text.
18 I '$O(^LAHM(62.49,LA76249,150,0)) D Q
19 . D CREATE^LA7LOG(6)
20 ;
21MSH S LA7MSH=$G(^($O(^LAHM(62.49,LA76249,150,0)),0))
22 ; Bad first line of message
23 I $E(LA7MSH,1,3)'="MSH" D Q
24 . D CREATE^LA7LOG(7)
25 S LA7FS=$E(LA7MSH,4)
26 S LA7CS=$E(LA7MSH,5)
27 S LA7ECH=$E(LA7MSH,5,8)
28 ; No field or component seperator
29 I LA7FS=""!(LA7CS="") D Q
30 . D CREATE^LA7LOG(8)
31 ;
32 ; Find the OBR segment
33 S LA762495=0
34OBR F S LA762495=$O(^LAHM(62.49,LA76249,150,LA762495)) Q:'LA762495!($E($G(^(+LA762495,0)),1,3)="OBR")
35 S DT=$$DT^XLFDT
36 ;
37 ; No more OBR's, found at least 1.
38 I 'LA762495,$L($G(LA7OBR)) Q
39 ;
40 S LA7OBR=$G(^LAHM(62.49,LA76249,150,+LA762495,0))
41 ;
42 ; Should only be working on OBR
43 I $E(LA7OBR,1,3)'="OBR" D Q
44 . D CREATE^LA7LOG(9)
45 ;
46 ; Extracting 1st piece
47 S LA7INST=$P($P(LA7OBR,LA7FS,19),LA7CS,1)
48 I LA7INST="" D Q
49 . D CREATE^LA7LOG(10)
50 S LA7624=+$O(^LAB(62.4,"B",LA7INST,0))
51 ; Instrument name not found in xref
52 I 'LA7624 D Q
53 . D CREATE^LA7LOG(11)
54 S LA7INST=$G(^LAB(62.4,LA7624,0))
55 ; Instrument entry not found in file
56 I LA7INST="" D Q
57 . D CREATE^LA7LOG(11)
58 ;
59 S LA7ENTRY=$P(LA7INST,"^",6) ;LOG,LLIST,IDENT or SEQN
60 S:LA7ENTRY="" LA7ENTRY="LOG"
61 ;
62 ; Universal service id
63 S LA7USID=$P(LA7OBR,LA7FS,4)
64 ;
65 S LA7TRAY=+$P($P(LA7OBR,LA7FS,20),LA7CS,1) ;Tray
66 S LA7CUP=+$P($P(LA7OBR,LA7FS,20),LA7CS,2) ; Cup
67 S LA7AA=+$P($P(LA7OBR,LA7FS,20),LA7CS,3) ; Accession Area
68 S LA7AD=+$P($P(LA7OBR,LA7FS,20),LA7CS,4) ; Accession Date
69 S LA7AN=+$P($P(LA7OBR,LA7FS,20),LA7CS,5) ; Accession Entry
70 S LA7ACC=$P($P(LA7OBR,LA7FS,20),LA7CS,6) ; Accession
71 S LA7UID=$P($P(LA7OBR,LA7FS,20),LA7CS,7) ; Unique ID
72 S LA7IDE=$P($P(LA7OBR,LA7FS,20),LA7CS,8) ; Sequence Number
73 S LA7LWL=$P(LA7INST,"^",4) ; Load/Work List
74 S LA7OBR3=$P(LA7OBR,LA7FS,3) ; Sample ID or Bar code
75 S LA7OBR(15)=$P(LA7OBR,LA7FS,16) ; Specimen source
76 ;
77 ; UID might come as Sample ID
78 I LA7UID="",LA7OBR3?10UN S LA7UID=LA7OBR3
79 ;
80 ; Try to figure out LRAA LRAD LRAN by using the unique ID (LRUID)
81 ; accession may have rolled over, use UID to get current accession info.
82 I LA7UID]"" D
83 . N X
84 . S X=$Q(^LRO(68,"C",LA7UID))
85 . I $QS(X,3)'=LA7UID S LA7UID="" Q ; UID not on file.
86 . S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6)
87 ; If still not known, compute from default date and accession area
88 ; Calculate accession date based on accession transform.
89 I '(LA7AA*LA7AD*LA7AN) D
90 . N X
91 . S DT=$$DT^XLFDT
92 . S LA7AA=+$P(LA7INST,"^",11)
93 . S X=$P($G(^LRO(68,LA7AA,0)),U,3)
94 . S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
95 . S LA7AN=+LA7OBR3
96 ; Log but cont
97 I LA7ENTRY="LOG",'$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D
98 . D CREATE^LA7LOG(13)
99 ; cup=sequence number
100 I LA7ENTRY="LLIST" S:'LA7CUP LA7CUP=LA7IDE
101 ;
102 ; Create entry in ^LAH global
103 D LAGEN
104 ; Couldn't create entry in ^LAH
105 I $G(LA7ISQN)="" D Q
106 . D CREATE^LA7LOG(14)
107 ;
108 ; specimen(topography), collection sample, HL7 specimen source
109 S (LA761,LA762,LA70070)=""
110 I $O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) D
111 . N X
112 . S X=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
113 . ; specimen^collection sample
114 . S X(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
115 . S LA761=$P(X(0),"^") ; specimen
116 . S LA762=$P(X(0),"^",2) ; collection sample
117 . ; HL7 code from Topography
118 . I LA761 S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
119 ;
120 ; Log error when specimen source does not match accession's specimen
121 I $L(LA70070),$L($P($P(LA7OBR(15),LA7CS),$E(LA7ECH,4))) D
122 . ; Check if using HL7 table 0070
123 . I $P($P(LA7OBR(15),LA7CS),$E(LA7ECH,4),3)'["0070" Q
124 . ; Message matches accession
125 . I LA70070=$P($P(LA7OBR(15),LA7CS),$E(LA7ECH,4)) Q
126 . D CREATE^LA7LOG(22)
127 . S LA7QUIT=1
128 ;
129 ; Something wrong, process next OBR
130 I LA7QUIT S LA7QUIT=0 G OBR
131 ;
132 ; Zeroth node of acession area.
133 S LA7AA(0)=$G(^LRO(68,+LA7AA,0))
134 ;
135 ; No subscript defined for this area.
136 I $P(LA7AA(0),"^",2)="" G OBR
137 ;
138 ; Processing of this subscript not supported.
139 I "CHMI"'[$P(LA7AA(0),"^",2) G OBR
140 ;
141 S LA7150=LA762495
142 ; Process "CH" subscript results - NTE and OBX segments.
143 I $P(LA7AA(0),"^",2)="CH" D NTE^LA7UIIN2
144 ;
145 ; Process "MI" subscript results.
146 I $P(LA7AA(0),"^",2)="MI" D
147 . N X
148 . S X="LA7UIIN3" X ^%ZOSF("TEST") Q:'$T
149 . D MI^LA7UIIN3
150 ;
151 ; No more segments to process, reached end of global array.
152 I 'LA762495 Q
153 ;
154 ; Reset subscript variable.
155 I LA762495>LA7150 S LA762495=LA762495-1
156 ;
157 ; Go back to find/process additional OBR segments.
158 G OBR
159 ;
160 ;
161LAGEN ; subroutine to set up variables for call to ^LAGEN, build entry in LAH
162 ; requires LA7INST,LA7TRAY,LA7CUP,LA7AA,LA7AD,LA7AN,LA7LWL
163 ; returns LA7ISQN=subscript to store results in ^LAH global
164 ;
165 K TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN
166 K LADT,LAGEN,LA7ISQN
167 ;
168 S LA7ISQN=""
169 S TRAY=+$G(LA7TRAY) S:'TRAY TRAY=1
170 S CUP=+$G(LA7CUP) S:'CUP CUP=1
171 S LWL=LA7LWL
172 I '$D(^LRO(68.2,+LWL,0)) D Q
173 . D CREATE^LA7LOG(19)
174 ;
175 ; Set accession area to area of specimen, allow multiple areas on same instrument.
176 S WL=LA7AA
177 I '$D(^LRO(68,+WL,0)) D Q
178 . D CREATE^LA7LOG(20)
179 ;
180 S LROVER=$P(LA7INST,"^",12)
181 S METH=$P(LA7INST,"^",10)
182 S LOG=LA7AN
183 ; Identity field
184 S IDENT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6)
185 S IDE=+LA7IDE
186 S LADT=LA7AD
187 ;
188 ; This disregards the CROSS LINK field in 62.4
189 D @(LA7ENTRY_"^LAGEN")
190 S LA7ISQN=$G(ISQN)
191 ;
192 Q
Note: See TracBrowser for help on using the repository browser.