source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7SMB.m@ 1484

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1LA7SMB ;DALOI/JMC - Shipping Manifest Build ;11/25/96 14:39
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64**;Sep 27, 1994
3EN ;
4 ;
5 D CLEANUP
6 S LA7QUIT=0
7 ;
8 ; Select shipping configuration
9 S LA7SCFG=$$SSCFG^LA7SUTL(1)
10 I LA7SCFG<1 D CLEANUP Q
11 ;
12 ; Determine if there's an active manifest.
13 S LA7SM=$$CHKSM^LA7SMU(+LA7SCFG)
14 I LA7SM<0 D Q
15 . D EN^DDIOL($P(LA7SM,"^",2),"","!?5")
16 . D CLEANUP
17 ;
18 I LA7SM=0 D
19 . N DIR,DIRUT,DTOUT,X,Y
20 . S DIR(0)="YO",DIR("A",1)="There's no open shipping manifest for "_$P(LA7SCFG,"^",2)
21 . S DIR("A")="Do you want to start one",DIR("B")="NO"
22 . D ^DIR
23 . I Y'=1 S LA7QUIT=1 Q
24 . S LA7SM=$$CSM^LA7SMU(+LA7SCFG)
25 . I LA7SM<1 D EN^DDIOL($P(LA7SM,"^",2),"","!?5") S LA7QUIT=1
26 ;
27 ; Only starting a new manifest, no building
28 I $G(LA7SMON) Q
29 ;
30 I LA7QUIT=1 D CLEANUP Q
31 ;
32 D ADATE^LA7SMU1
33 I LA7QUIT=1 D CLEANUP Q
34 ;
35 ; Flag to exclude previously removed tests from building.
36 S LA7EXPRV=$$ASKPREV^LA7SMU1
37 I LA7EXPRV<0 S LA7QUIT=1
38 ;
39 I LA7QUIT=1 D CLEANUP Q
40 ;
41DQ ; Taskman entry point
42 ; Build list of tests and criteria for manifest.
43 S LA7SCFG(0)=$G(^LAHM(62.9,+LA7SCFG,0))
44 I '$D(ZTQUEUED) D EN^DDIOL("Using shipping manifest# "_$P(LA7SM,"^",2),"","!?5")
45 ;
46 ; Lock this shipping manifest
47 L +^LAHM(62.8,+LA7SM,0):5
48 I '$T D Q
49 . I '$D(ZTQUEUED) D EN^DDIOL("Unable to obtain lock for shipping manifest "_$P(LA7SCFG,"^",2),"","!?5")
50 . D CLEANUP
51 ;
52 ; Update status
53 D SMSUP^LA7SMU(LA7SM,2,"SM03")
54 S LA7SMCNT=0
55 ;
56 ; Build TMP global with test profiles
57 D SCBLD^LA7SM1(+LA7SCFG)
58 S LA7AA=""
59 F S LA7AA=$O(^TMP("LA7SMB",$J,LA7AA)) Q:LA7AA="" D
60 . N LA7END,LRSS
61 . I '$D(ZTQUEUED) D EN^DDIOL("Searching accession area: "_$P($G(^LRO(68,LA7AA,0)),"^"),"","!?5")
62 . ; Use selected accession date else get current accession day for this acession area
63 . I $G(LA7AA(LA7AA)) S LA7AD=$P(LA7AA(LA7AA),"^")
64 . E S LA7AD=$$AD^LA7SUTL(LA7AA)
65 . S LRSS=$P($G(^LRO(68,LA7AA,0)),"^",2)
66 . S LA7AN=+$P($G(LA7AA(LA7AA)),"^",2),LA7LAN=+$P($G(LA7AA(LA7AA)),"^",3),LA7END=0
67 . I LA7AN S LA7AN=LA7AN-1
68 . F S LA7AN=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN)) Q:'LA7AN!(LA7END) D SCAN
69 ;
70 ; Update status
71 D SMSUP^LA7SMU(LA7SM,1,"SM02")
72 ;
73 ; Release lock on this shipping manifest
74 L -^LAHM(62.8,+LA7SM,0)
75 ;
76 I '$D(ZTQUEUED) D
77 . N DIR,DIRUT,DIROUT,DTOUT,X,Y
78 . D EN^DDIOL("There were "_$S(LA7SMCNT:LA7SMCNT,1:"NO")_" specimens added","","!?5")
79 . D ASK^LA7SMP(LA7SM)
80 D CLEANUP
81 Q
82 ;
83SMONLY ; Start a shipping manifest only, no building
84 ;
85 N LA7SMON
86 S LA7SMON=1
87 D EN
88 I $G(LA7SCFG),$G(LA7SM)>0 D EN^DDIOL("Shipping manifest# "_$P(LA7SM,"^",2)_" is available","","!?5")
89 D CLEANUP
90 Q
91 ;
92 ;
93SCAN ; Scan accession for tests to build
94 ;
95 N LA76805,LA7DIV,LA7END
96 ;
97 I LA7LAN,LA7AN>LA7LAN S LA7END=1 Q
98 ;
99 ; Don't build controls
100 I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)=62.3 Q
101 ;
102 ; Don't build uncollected specimens
103 I '$P(LA7SCFG(0),"^",14),'$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3)),"^",3) Q
104 ;
105 ; Get Specimen type - if no specimen then quit
106 ; Anatomic path does not store specimen type in #68.
107 S LA76805=""
108 I "CY^EM^SP"[LRSS S LA76805=0
109 E D
110 . S X=+$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
111 . I 'X Q
112 . S LA76805=+$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
113 I LA76805="" Q
114 ;
115 ; Accession's division
116 S LA7DIV=+$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.4)),"^")
117 ;
118 S LA760=0
119 F S LA760=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760)) Q:'LA760 D
120 . ; Not looking for this test.
121 . I '$D(^TMP("LA7SMB",$J,LA7AA,LA760)) Q
122 . ; Set lock.
123 . D LOCK68
124 . ; NOTE *** Do NOT add any "QUIT" after this point unless releasing LOCK set above ***.
125 . ; Test's zeroth node.
126 . S LA760(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760,0))
127 . ; Test completed - skip
128 . I "CY^EM^SP"'[LRSS,$P(LA760(0),"^",5) D UNLOCK68 Q
129 . ; Test already on shipping manifest - skip
130 . I $P(LA760(0),"^",10) D UNLOCK68 Q
131 . ; Previously removed - skip
132 . I LA7EXPRV,$$PREV^LA7SMU1($P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^"),$P(LA760(0),"^")) D UNLOCK68 Q
133 . ; Test urgency
134 . S LA76205=+$P(LA760(0),"^",2)
135 . I LA76205>49 S LA76205=$S(LA76205=50:9,1:LA76205-50)
136 . ; Check if test is eligible for manifest
137 . D SCHK^LA7SM1
138 . I LA7FLAG S LA7FLAG=$$CKTEST(LA7AA,LA7AD,LA7AN,LA760)
139 . ; Add test to shipping manifest.
140 . I LA7FLAG D
141 . . S LA7I=0
142 . . F S LA7I=$O(LA7X(LA7I)) Q:'LA7I D ADD
143 . ; Release lock.
144 . D UNLOCK68
145 Q
146 ;
147ADD ; Add test to shipping manifest
148 ; Called from above, LA7SM
149 ; Lock on ^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760) should be set before entering here.
150 ;
151 N FDA,IENS,LA7628,LA768,LA7DATA
152 ;
153 S LRDFN=+$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0))
154 S LA7UID=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^")
155 I LA7UID="" S LA7UID=$$LRUID^LRX(LA7AA,LA7AD,LA7AN)
156 S LA7SMCNT=$G(LA7SMCNT)+1
157 S ^TMP("LA7SMADD",$J,LA7SMCNT)=LRDFN_"^"_LA760_"^"_LA76805_"^"_LA76205_"^"_LA7UID
158 S LA7628(1)=+LA7SM,IENS="+2,"_LA7628(1)_","
159 S FDA(2,62.801,IENS,.01)=LRDFN
160 S FDA(2,62.801,IENS,.02)=LA760
161 I LA76805 S FDA(2,62.801,IENS,.03)=LA76805
162 S FDA(2,62.801,IENS,.04)=LA76205
163 S FDA(2,62.801,IENS,.05)=LA7UID
164 S FDA(2,62.801,IENS,.08)=1
165 I $D(LA7X(LA7I,0)) D
166 . I $P(LA7X(LA7I,0),"^",5) S FDA(2,62.801,IENS,.06)=$P(LA7X(LA7I,0),"^",5)
167 . I $P(LA7X(LA7I,0),"^",6) S FDA(2,62.801,IENS,.07)=$P(LA7X(LA7I,0),"^",6)
168 . I $P(LA7X(LA7I,0),"^",7) S FDA(2,62.801,IENS,.09)=$P(LA7X(LA7I,0),"^",7)
169 I $D(LA7X(LA7I,1)) D
170 . I $P(LA7X(LA7I,1),"^",1)]"" S FDA(2,62.801,IENS,1.1)=$P(LA7X(LA7I,1),"^",1)
171 . I $P(LA7X(LA7I,1),"^",2)]"" S FDA(2,62.801,IENS,1.13)=$P(LA7X(LA7I,1),"^",2)
172 . I $P(LA7X(LA7I,1),"^",5)]"" S FDA(2,62.801,IENS,1.14)=$P(LA7X(LA7I,1),"^",5)
173 . I $P(LA7X(LA7I,1),"^",3)]"" S FDA(2,62.801,IENS,1.2)=$P(LA7X(LA7I,1),"^",3)
174 . I $P(LA7X(LA7I,1),"^",4)]"" S FDA(2,62.801,IENS,1.23)=$P(LA7X(LA7I,1),"^",4)
175 . I $P(LA7X(LA7I,1),"^",6)]"" S FDA(2,62.801,IENS,1.24)=$P(LA7X(LA7I,1),"^",6)
176 I $D(LA7X(LA7I,2)) D
177 . I $P(LA7X(LA7I,2),"^",1)]"" S FDA(2,62.801,IENS,2.1)=$P(LA7X(LA7I,2),"^",1)
178 . I $P(LA7X(LA7I,2),"^",2)]"" S FDA(2,62.801,IENS,2.13)=$P(LA7X(LA7I,2),"^",2)
179 . I $P(LA7X(LA7I,2),"^",7)]"" S FDA(2,62.801,IENS,2.14)=$P(LA7X(LA7I,2),"^",7)
180 . I $P(LA7X(LA7I,2),"^",3)]"" S FDA(2,62.801,IENS,2.2)=$P(LA7X(LA7I,2),"^",3)
181 . I $P(LA7X(LA7I,2),"^",4)]"" S FDA(2,62.801,IENS,2.23)=$P(LA7X(LA7I,2),"^",4)
182 . I $P(LA7X(LA7I,2),"^",8)]"" S FDA(2,62.801,IENS,2.24)=$P(LA7X(LA7I,2),"^",8)
183 . I $P(LA7X(LA7I,2),"^",5)]"" S FDA(2,62.801,IENS,2.3)=$P(LA7X(LA7I,2),"^",5)
184 . I $P(LA7X(LA7I,2),"^",6)]"" S FDA(2,62.801,IENS,2.33)=$P(LA7X(LA7I,2),"^",6)
185 . I $P(LA7X(LA7I,2),"^",9)]"" S FDA(2,62.801,IENS,2.34)=$P(LA7X(LA7I,2),"^",9)
186 I $D(LA7X(LA7I,5)) D
187 . F I=1:1:9 I $P(LA7X(LA7I,5),"^",I)]"" S FDA(2,62.801,IENS,"5."_I)=$P(LA7X(LA7I,5),"^",I)
188 D UPDATE^DIE("","FDA(2)","LA7628","LA7DIE(2)")
189 ;
190 ; Update event file
191 S LA7DATA="SM50^"_$$NOW^XLFDT_"^"_LA760_"^"_$P(LA7SM,"^",2)
192 D SEUP^LA7SMU(LA7UID,2,LA7DATA)
193 ;
194 ; Update accession
195 D ACCSUP^LA7SMU(LA7UID,LA760,+LA7SM)
196 Q
197 ;
198 ;
199CKTEST(LA7AA,LA7AD,LA7AN,LA760) ; Check other tests on accession if test is part of another panel that
200 ; has been flagged for shipping.
201 ; Call with LA7AA = ien of accession area.
202 ; LA7AD = accession date
203 ; LA7AN = accession number
204 ; LA760 = ien of lab test
205 ; Returns LA7FLAG = 0 (part of another panel)
206 ; = 1 (not part of another panel)
207 ;
208 N LA7FLAG,LA7PCNT,LA7K,LA7J,X
209 ;
210 K ^TMP("LA7TREE",$J)
211 ;
212 S LA7FLAG=1
213 S LA7AD(LA7AD)=""
214 S LA7K=+$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",3)
215 ;
216 I LA7K D
217 . ; Check original accession date.
218 . S LA7AD(LA7K)=""
219 . ; Check rollover accession
220 . I $P($G(^LRO(68,LA7AA,1,LA7K,1,LA7AN,9)),"^") S LA7AD($P($G(^LRO(68,LA7AA,1,LA7K,1,LA7AN,9)),"^"))=""
221 S LA7AD=0
222 F S LA7AD=$O(LA7AD(LA7AD)) Q:'LA7AD D
223 . S LA7J=0
224 . F S LA7J=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA7J)) Q:'LA7J D
225 . . I LA7J=LA760 Q
226 . . ; Not on manifest
227 . . I '$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA7J,0)),"^",10) Q
228 . . S LA7PCNT=0 D UNWIND(LA7J)
229 ;
230 ; Test is part of another test previously shipped.
231 I $D(^TMP("LA7TREE",$J,LA760)) S LA7FLAG=0
232 ;
233 K ^TMP("LA7TREE",$J)
234 ;
235 Q LA7FLAG
236 ;
237UNWIND(LA760) ; Unwind profile - set tests into global ^TMP("LA7TREE",$J).
238 ; Initialize variable LA7PCNT=0 before calling.
239 ; Kill ^TMP("LA7TREE",$J) before calling.
240 ;
241 N I,II
242 ;
243 ; Recursive panel, caught in a loop.
244 I $G(LA7PCNT)>50 Q
245 ; Test does not exist in file 60.
246 I '$D(^LAB(60,LA760,0)) Q
247 ; Bypass "workload" type tests.
248 I $P(^LAB(60,LA760,0),"^",4)="WK" Q
249 ; Atomic test
250 I $L($P(^LAB(60,LA760,0),"^",5)) S ^TMP("LA7TREE",$J,LA760)="" Q
251 ; Check panels
252 I $O(^LAB(60,LA760,2,0)) D
253 . ; Increment panel counter.
254 . S LA7PCNT=$G(LA7PCNT)+1
255 . S I=0
256 . ; Expand test on panel.
257 . F S I=$O(^LAB(60,LA760,2,I)) Q:'I D
258 . . ; IEN of test on panel.
259 . . S II=+$G(^LAB(60,LA760,2,I,0))
260 . . ; Recursive panel, panel calls itself.
261 . . I II,II=LA760 Q
262 . . I II S ^TMP("LA7TREE",$J,LA760)="" D UNWIND(II)
263 Q
264 ;
265LOCK68 ; Lock entry in file 68
266 ; Called from above, LA7SM
267 ;
268 L +^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760):9999 ; Set lock.
269 ;
270 Q
271 ;
272UNLOCK68 ; Unlock entry in file 68
273 ; Called from above, LA7SM
274 ;
275 L -^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760) ; Release lock.
276 ;
277 Q
278 ;
279CLEANUP ; Cleanup variables
280 ;
281 I $D(ZTQUEUED) S ZTREQ="@"
282 ;
283 K ^TMP("LA7SMB",$J),^TMP("LA7SMADD",$J),^TMP("LA7TREE",$J)
284 ;
285 K LA760,LA76205,LA76805,LA7AA,LA7AD,LA7AN,LA7EXPRV,LA7FLAG,LA7LAN,LA7PCNT,LA7QUIT,LA7SCFG,LA7SM,LA7SMCNT,LA7UID,LA7X
286 K LRDFN
287 Q
Note: See TracBrowser for help on using the repository browser.