source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VORM1.m@ 1656

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

initial load of FOIAVistA 6/30/08 version
File size: 7.6 KB
Line 
1LA7VORM1 ;DALOI/DLR - LAB ORM (Order) message builder ; 12-12-96
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,51,46,61,64**;Sep 27, 1994
3 ;
4BUILD(LA7628) ;
5 ; Call with LA7628 = ien of entry in file #62.8 Shipping Manifest
6 ;
7 N LA7101,LA762801,LA7629,LA7NVAF,LA7PIDSN,LA7X,ECNT,GBL,SHP,SHPC,SITE,ORUID,NTST
8 ;
9 I $G(LA7628)<1!('$D(^LAHM(62.8,+$G(LA7628),0))) D Q
10 . ; Need to add error logging for manifest not found.
11 . D EXIT
12 ;
13 S GBL="^TMP(""HLS"","_$J_")",ECNT=1
14 S LA7628(0)=$G(^LAHM(62.8,LA7628,0))
15 S LA7629=$P(LA7628(0),U,2)
16 S LA7629(0)=$G(^LAHM(62.9,LA7629,0))
17 S LA76248=+$P(LA7629(0),"^",7)
18 S LA76248(0)=$G(^LAHM(62.48,LA76248,0))
19 I '$P(LA76248(0),"^",3) D EXIT Q ; not active
20 ;
21 S LA7V("INST")=$P(LA7629(0),U,11)
22 Q:LA7V("INST")=$P(LA7629(0),U,6) ;Same system shipment
23 ;
24 S LA7NVAF=$$NVAF^LA7VHLU2(+LA7V("INST")),SITE=""
25 I LA7NVAF=0 S SITE=$$GET1^DIQ(4,+$P(LA7629(0),U,11)_",",99)
26 I LA7NVAF=1 S SITE=$$ID^XUAF4("DMIS",+$P(LA7629(0),U,11))
27 S LA7V("NON")=$P(LA7629(0),U,12)
28 I LA7V("NON")'="" S SITE=LA7V("NON")
29 ;
30 S LA7X=$$NVAF^LA7VHLU2(+$P(LA7629(0),U,2))
31 I LA7X=0 S LA7V("CLNT")=$$GET1^DIQ(4,+$P(LA7629(0),U,2)_",",99)
32 I LA7X=1 S LA7V("CLNT")=$$ID^XUAF4("DMIS",+$P(LA7629(0),U,2))
33 S $P(LA7V("CLNT"),U,2)=$$GET1^DIQ(4,+$P(LA7629(0),U,2)_",",.01)
34 ;
35 S LA7X=$$NVAF^LA7VHLU2(+$P(LA7629(0),U,3))
36 I LA7X=0 S LA7V("HOST")=$$GET1^DIQ(4,+$P(LA7629(0),U,3)_",",99)
37 I LA7X=1 S LA7V("HOST")=$$ID^XUAF4("DMIS",+$P(LA7629(0),U,3))
38 S $P(LA7V("HOST"),U,2)=$$GET1^DIQ(4,+$P(LA7629(0),U,3)_",",.01)
39 ;
40 ; Assuming the receiving institution is the primary site (site with the computer system)
41 ;
42 ; Sort tests by patient,UID,test - only need to build one PID, PV1 per patient
43 ; ^TMP("LA7628",$J, LRDFN, accession UID, ien of shipping manifest specimen entry)
44 K ^TMP("LA7628",$J)
45 S LA762801=0
46 F S LA762801=$O(^LAHM(62.8,LA7628,10,LA762801)) Q:'LA762801 D
47 . S X(0)=$G(^LAHM(62.8,LA7628,10,LA762801,0))
48 . I $P(X(0),"^",8)=0 Q ; Removed from manifest
49 . I $P(X(0),"^"),$L($P(X(0),"^",5)) S ^TMP("LA7628",$J,+$P(X(0),"^"),$P(X(0),"^",5),LA762801)=""
50 K LA762801
51 ;
52 ; Nothing to send
53 I '$D(^TMP("LA7628",$J)) D EXIT Q
54 ;
55 ; Set flag = 0 (multiple PID's/message - build one message)
56 ; 1 (one PID/message - build multiple messages)
57 ; 2 (one ORC/message - build multiple messages)
58 S LA7SMSG=+$P(LA76248(0),"^",8)
59 ;
60 I LA7SMSG=0 D Q:$G(HL)
61 . D STARTMSG
62 . I $G(HL) D EXIT
63 ;
64 S (LRDFN,LRI,LA7PIDSN)=0
65 F S LRDFN=$O(^TMP("LA7628",$J,LRDFN)) Q:'LRDFN D Q:$G(HL)
66 . N LA7PID,LA7PV1
67 . I LA7SMSG=1 D STARTMSG Q:$G(HL)
68 . I LA7SMSG<2 D PID,PV1
69 . S LA7UID=""
70 . F S LA7UID=$O(^TMP("LA7628",$J,LRDFN,LA7UID)) Q:LA7UID="" D
71 . . N LA76802,LA7ORC,X
72 . . S X=$Q(^LRO(68,"C",LA7UID))
73 . . I $QS(X,3)'=LA7UID Q
74 . . S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
75 . . F I=0,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I))
76 . . S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
77 . . S LA76802(5)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,I,0))
78 . . I LA7SMSG=2 D STARTMSG Q:$G(HL) D PID,PV1
79 . . S (LA7OBRSN,LA762801)=0
80 . . F S LA762801=$O(^TMP("LA7628",$J,LRDFN,LA7UID,LA762801)) Q:'LA762801 D
81 . . . N LA7OBR,I
82 . . . F I=0,.1,1,2,5 S LA762801(I)=$G(^LAHM(62.8,LA7628,10,LA762801,I))
83 . . . I $$CHKTST^LA7SMU(LA7628,LA762801)'=0 Q ;deleted accession
84 . . . D ORC,OBR^LA7VORM3,OBX^LA7VORM3
85 . . I LA7SMSG=2 D BLG,SENDMSG
86 . I LA7SMSG<2 D BLG
87 . I LA7SMSG=1 D SENDMSG
88 ;
89 I LA7SMSG=0 D SENDMSG
90 ;
91 ;
92EXIT ;
93 K @GBL,^TMP("LA7628",$J)
94 K DIC,DFN,EID,HL,HLCOMP,HLFS,HLQ,HLSUB,INT
95 K LA760,LA7628,LA762801,LA7629
96 K LA7ECH,LA7FS,LA7MID,LA7V,LA7HDR,LA7OBRSN,LA7OBXSN,LA7VIEN,LAEVNT
97 K LRAA,LRACC,LRAD,LRAN,LRDFN,LRI
98 K LTST,NLT,NLTIEN,PCNT,RUID,SNIEN,TIEN,X,Y,LA
99 D KVAR^LRX
100 I $D(ZTQUEUED) S ZTREQ="@"
101 Q
102 ;
103 ;
104STARTMSG ; Create/initialize HL message
105 ;
106 K @GBL
107 S (LA76249,LA7PIDSN)=0
108 D STARTMSG^LA7VHLU("LA7V Order to "_SITE,.LA76249)
109 Q
110 ;
111 ;
112SENDMSG ; File HL7 message with HL and LAB packages.
113 ;
114 N LA7DATA,LA7ID
115 S LA7ID="LA7V HOST "_SITE_"-O-"_$P($G(LA7628(0)),"^")
116 ; If no message to send then quit
117 I '$D(^TMP("HLS",$J)) D Q
118 . N FDA,LA7ER
119 . I $G(LA76248) S FDA(1,62.49,LA76249_",",.5)=LA76248
120 . S FDA(1,62.49,LA76249_",",1)="O"
121 . S FDA(1,62.49,LA76249_",",2)="E"
122 . S FDA(1,62.49,LA76249_",",5)=LA7ID
123 . D FILE^DIE("","FDA(1)","LA7ER(1)")
124 . D CLEAN^DILF
125 . L -^LAHM(62.49,LA76249)
126 ;
127 D GEN^LA7VHLU
128 S LA7DATA="SM06"_"^"_$$NOW^XLFDT
129 D SEUP^LA7SMU($P(LA7628(0),"^"),"1",LA7DATA)
130 D UPDT6249
131 ; Unlock entry
132 L -^LAHM(62.49,LA76249)
133 Q
134 ;
135 ;
136UPDT6249 ; update entry in 62.49
137 ;
138 N FDA,LA7ER
139 ;
140 I $G(LA76248) S FDA(1,62.49,LA76249_",",.5)=LA76248
141 S FDA(1,62.49,LA76249_",",1)="O"
142 I $P(^LAHM(62.49,LA76249,0),"^",3)'="E" D
143 . I $G(HL("APAT"))="AL" S FDA(1,62.49,LA76249_",",2)="A"
144 . E S FDA(1,62.49,LA76249_",",2)="X"
145 . I $G(LA7ERR) S FDA(1,62.49,LA76249_",",2)="E"
146 S FDA(1,62.49,LA76249_",",5)=LA7ID
147 I $G(HL("SAN"))'="" S FDA(1,62.49,LA76249_",",102)=HL("SAN")
148 I $G(HL("SAF"))'="" S FDA(1,62.49,LA76249_",",103)=HL("SAF")
149 I $G(HL("MTN"))'="" S FDA(1,62.49,LA76249_",",108)=HL("MTN")
150 I $G(HL("PID"))'="" S FDA(1,62.49,LA76249_",",110)=HL("PID")
151 I $G(HL("VER"))'="" S FDA(1,62.49,LA76249_",",111)=HL("VER")
152 I $P($G(LA7MID),"^")'="" S FDA(1,62.49,LA76249_",",109)=$P(LA7MID,"^")
153 I $P($G(LA7MID),"^",2) D
154 . S FDA(1,62.49,LA76249_",",160)=$P(LA7MID,"^",2)
155 . S FDA(1,62.49,LA76249_",",161)=$P(LA7MID,"^",3)
156 D FILE^DIE("","FDA(1)","LA7ER(1)")
157 D CLEAN^DILF
158 Q
159 ;
160 ;
161PID ; Patient identification
162 S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
163 D DEM^LRX
164 D PID^LA7VPID(LRDFN,"",.LA7PID,.LA7PIDSN,.HL,"")
165 ; DoD/CHCS facilities only use 1st repetition of PID-3.
166 I LA7NVAF=1 D
167 . S X=$P(LA7PID(0),LA7FS,4),X=$P(X,$E(LA7ECH,2))
168 . S $P(LA7PID(0),LA7FS,4)=X
169 D FILESEG^LA7VHLU(GBL,.LA7PID)
170 D FILE6249^LA7VHLU(LA76249,.LA7PID)
171 Q
172 ;
173 ;
174PV1 ; Location information
175 ; DoD/CHCS facilities do not use PV1 segment
176 I LA7NVAF=1 Q
177 ;
178 D PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)
179 D FILESEG^LA7VHLU(GBL,.LA7PV1)
180 D FILE6249^LA7VHLU(LA76249,.LA7PV1)
181 Q
182 ;
183 ;
184ORC ;Order Control
185 ;
186 N ORC,LA7DATA,LA7DUR,LA7DURU,LA76205,LA762801,LA7X
187 ;
188 S ORC(0)="ORC"
189 S ORC(1)=$$ORC1^LA7VORC("NW")
190 ;
191 ; Place order number - accession UID
192 S ORC(2)=$$ORC2^LA7VORC($P(LA76802(.3),"^"),LA7FS,LA7ECH)
193 ;
194 ; Placer group number - shipping manifest invoice #
195 S ORC(4)=$$ORC4^LA7VORC($P(LA7628(0),"^"),LA7FS,LA7ECH)
196 ;
197 ; Quantity/Timing
198 S (LA76205,LA7DUR,LA7DURU)=""
199 S LA762801=0
200 F S LA762801=$O(^TMP("LA7628",$J,LRDFN,LA7UID,LA762801)) Q:'LA762801 D
201 . N I,LA760
202 . ; Test duration
203 . F I=0,2 S LA762801(I)=$G(^LAHM(62.8,LA7628,10,LA762801,I))
204 . I $P(LA762801(2),"^",4) D
205 . . S LA7DUR=$P(LA762801(2),"^",6) ; collection duration
206 . . S LA7DURU=$P(LA762801(2),"^",7) ; duration units
207 . ; Test urgency - find highest urgency on accession
208 . S LA760=+$P(LA762801(0),"^",2)
209 . S X=+$$GET1^DIQ(68.04,LA760_","_LRAN_","_LRAD_","_LRAA_",",1,"I")
210 . I 'LA76205 S LA76205=X
211 . I LA76205,X<LA76205 S LA76205=X
212 S ORC(7)=$$ORC7^LA7VORC(LA7DUR,LA7DURU,LA76205,LA7FS,LA7ECH)
213 ;
214 ; Order Date/Time - if no order date/time then try draw time
215 I $P(LA76802(0),"^",4) S ORC(9)=$$ORC9^LA7VORC($P(LA76802(0),"^",4))
216 I '$P(LA76802(0),"^",4),$P(LA76802(3),"^") S ORC(9)=$$ORC9^LA7VORC($P(LA76802(3),"^"))
217 ;
218 ; Ordering provider
219 S LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
220 S ORC(12)=$$ORC12^LA7VORC($P(LA76802(0),"^",8),$P(LA7X,"^",3),LA7FS,LA7ECH)
221 ;
222 ; Entering organization - VA facility
223 S ORC(17)=$$ORC17^LA7VORC($P($G(LA7629(0)),U,2),LA7FS,LA7ECH)
224 ;
225 D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
226 D FILESEG^LA7VHLU(GBL,.LA7DATA)
227 D FILE6249^LA7VHLU(LA76249,.LA7DATA)
228 Q
229 ;
230 ;
231BLG ; Billing segment
232 ;
233 N LA7BLG
234 ;
235 I $P(LA7629(0),U,13)="" Q
236 S LA7BLG(0)=$$BLG^LA7VHLU($P(LA7629(0),"^",13),"CO",LA7FS,LA7ECH)
237 D FILESEG^LA7VHLU(GBL,.LA7BLG)
238 D FILE6249^LA7VHLU(LA76249,.LA7BLG)
239 Q
Note: See TracBrowser for help on using the repository browser.