source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRWLST1.m@ 675

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

initial load of FOIAVistA 6/30/08 version
File size: 9.9 KB
Line 
1LRWLST1 ;DALOI/CJS/RWF/FHS - ACCESSION SETUP ; July 19, 2006
2 ;;5.2;LAB SERVICE;**48,65,121,153,261,286,331,379**;Sep 27, 1994;Build 2
3 ;
4 ; Reference to ^DIC(42 supported by IA #10039
5 ; Reference to ^SC( supported by IA #10040
6 ;
7 S LRWLC=0
8 F S LRWLC=$O(LRTSTS(LRWLC)) Q:LRWLC<1 S LRAD=DT D SPLIT
9 ;
10 ; If LEDI and comments came with order then copy to order in #69
11 I $G(LRORDRR)="R",$G(LR696),$D(^LRO(69.6,LR696,99)) D
12 . N LRDIE
13 . D WP^DIE(69.01,LRSN_","_LRODT_",",16,"A","^LRO(69.6,LR696,99)","LRDIE(16)")
14 ;
15 K DIC,DLAYGO,DR,DA,DIE,LRIXX
16 Q:$G(LRORDR)="P"
17 K LRNM,LRTSTS
18 K ^TMP("LR",$J,"TMP")
19 Q
20 ;
21SPLIT ;
22 N LRAA,LRX
23 ; Setup regular accessions (LRUNQ=0)
24 S LRUNQ=0,LREND=0
25 I $D(LRTSTS(LRWLC,0)) D
26 . D GTWLN
27 . I LREND Q
28 . S LRAA=0
29 . F S LRAA=$O(LRTSTS(LRWLC,0,LRAA)) Q:LRAA<1 D
30 . . S LRSS=LRTSTS(LRWLC,0,LRAA)
31 . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID)
32 . D SICA^LRWLST11
33 ;
34 ; Setup accessions requiring 'unique' accession numbers (LRUNQ=1)
35 S LRUNQ=1,LRAA=0
36 F S LRAA=$O(LRTSTS(LRWLC,1,LRAA)) Q:LRAA<1 D
37 . S LRSS=LRTSTS(LRWLC,1,LRAA)
38 . F D GTWLN Q:LREND D Q:$O(LRTSTS(LRWLC,1,LRAA,0))<1
39 . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID),SICA^LRWLST11
40 Q
41 ;
42 ;
43STWLN ; Set accession number
44 ;
45 D GETLOCK(LRAA,LRAD)
46 D CHECK68(LRAA,LRAD)
47 ;
48 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
49 ;
50 ; Handle 'in common' area that was not setup in GTWLN call.
51 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) D SETAN(LRAA,LRAD,LRAN)
52 ;
53 S LREND=0,LRLBLBP=1-$P(LRSS,U,2),LRSS=$P(LRSS,U)
54 S LRACC=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN
55 ;
56 S LRPRAC=""
57 I $D(^LRO(69,LRODT,1,LRSN,0)) S LRPRAC=$P(^(0),U,6) S:$D(LRNT) ^(3)=LRNT
58 ;
59 ; Location type
60 S LRCAPLOC=$P($G(^SC(+LROLLOC,0)),U,3)
61 I LRCAPLOC="" S LRCAPLOC="Z"
62 ;
63 ; File information in file #68 for this accession
64 N FDA,LR6802,LRDIE
65 S LR6802=LRAN_","_LRAD_","_LRAA_","
66 S FDA(1,68.02,LR6802,.01)=LRDFN
67 S FDA(1,68.02,LR6802,1)=LRDPF
68 S FDA(1,68.02,LR6802,2)=LRAD
69 S FDA(1,68.02,LR6802,3)=LRODT
70 S FDA(1,68.02,LR6802,4)=LRSN
71 S FDA(1,68.02,LR6802,6)=LRLLOC
72 S X=$G(^LRO(69,LRODT,1,LRSN,.1)) I X'="" S FDA(1,68.02,LR6802,14)=X
73 ;
74 ; No ordering provider/location on controls
75 I LRDPF'=62.3 D
76 . S FDA(1,68.02,LR6802,6.5)=LRPRAC
77 . S FDA(1,68.02,LR6802,94)=LROLLOC
78 ;
79 ; Only store treating specialty on file #2 patients
80 ; If no treating specialty then use specialty from file #44 location
81 I LRDPF=2 D
82 . S LRTREA=$P($G(^DPT(DFN,.103)),U)
83 . I 'LRTREA S LRTREA=$P($G(^SC(+LROLLOC,0)),U,20)
84 . I LRTREA S FDA(1,68.02,LR6802,6.6)=LRTREA
85 ;
86 S FDA(1,68.02,LR6802,6.7)=DUZ
87 S FDA(1,68.02,LR6802,15)=LRACC
88 S FDA(1,68.02,LR6802,26)=DUZ(2)
89 S FDA(1,68.02,LR6802,92)=LRCAPLOC
90 ;
91 D FILE^DIE("","FDA(1)","LRDIE(1)")
92 I $D(LRDIE(1)) D MAILALRT
93 ;
94 ; If specimen defined then set nodes, force to ien=1 since many lab
95 ; routines expect the specimen to be record number 1.
96 I $G(LRSPEC) D
97 . N FDAIEN
98 . S FDAIEN(1)=1
99 . S FDA(2,68.05,"+1,"_LR6802,.01)=LRSPEC
100 . S FDA(2,68.05,"+1,"_LR6802,1)=$P(LRSAMP,";",1)
101 . ;
102 . ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
103 . N LRLOCKOK,LRLOOPCT
104 . S LRLOCKOK=0
105 . F LRLOOPCT=1:1:10 Q:LRLOCKOK D I 'LRLOCKOK H 5
106 . . K LRDIE(2)
107 . . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
108 . . S:$D(LRDIE(2))=0 LRLOCKOK=1
109 . K LRLOCKOK,LRLOOPCT
110 . ;
111 . ;D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
112 . I $D(LRDIE(2)) D MAILALRT
113 ;
114 ; If no specimen defined then use specimen values from file #69.
115 I $G(LRSPEC)="",$D(^LRO(69,LRODT,1,LRSN,4,0)) D
116 . N FDA,FDAIEN,LRI,LRX
117 . S LRI=0
118 . F S LRI=$O(^LRO(69,LRODT,1,LRSN,4,LRI)) Q:'LRI D
119 . . S FDAIEN(1)=LRI,LRX=$G(^LRO(69,LRODT,1,LRSN,4,LRI,0))
120 . . S FDA(LRI,68.05,"+1,"_LR6802,.01)=$P(LRX,"^")
121 . . D UPDATE^DIE("","FDA(LRI)","FDAIEN","LRDIE(LRI)")
122 . . I $D(LRDIE(LRI)) D MAILALRT
123 ;
124 ; Create UID.
125 S LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN)
126 ;
127 I '$D(LRPHSET),('$G(LRQUIET)) W !!,"ACCESSION: ",LRACC," <",LRUID,">"
128 ;
129 D UPD696
130 ;
131 L -^LRO(68,LRAA,1,LRAD,1,0)
132 Q
133 ;
134 ;
135UPD696 ; Update file #69.6 if LEDI referral patient and no existing entry
136 K LR696IEN
137 I $G(LRORDRR)="R" D
138 . S LR696IEN=0
139 . I $G(LRRSITE("SMID"))'="",$G(LRSD("RUID"))'="" S LR696IEN=+$O(^LRO(69.6,"AD",LRRSITE("SMID"),LRSD("RUID"),0))
140 . I LR696IEN Q
141 . I '$G(LRRSTAT(0)) S LRRSTAT(0)=$$FIND1^DIC(64.061,"","OMX","Specimen in process","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
142 . D PSET^LRPEND(SSN(2),+LRRSITE("RSITE"),LRSD("RUID"),+LRSD("RPSITE"),LRSPEC,LRSAMP,LRRSTAT(0),LRODT,$P(LRCDT,U),LRRSITE("SDT"),LRNT,.LROT)
143 Q
144 ;
145 ;
146ST2 ; Find next available node in LR global
147 ;
148 N FDA,FDAIEN,LRDIE,LRX,LRXIDT
149 ;
150 ; Autopsy ("AU") is not a mulitple - do not attempt to set in ^LR global
151 I LRSS="AU" S LRIDT=0 Q
152 ;
153 S LRIDT=0
154 F D Q:LRIDT
155 . S LRXIDT=9999999-LRCDT
156 . L +^LR(LRDFN,LRSS,LRXIDT,0):5
157 . I '$T S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1) Q
158 . I '$D(^LR(LRDFN,LRSS,LRXIDT,0)) S LRIDT=LRXIDT Q
159 . L -^LR(LRDFN,LRSS,LRXIDT,0)
160 . S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1)
161 ;
162 ; Create entry in appropriate subscript in LAB DATA file (#63).
163 S LRX=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="BB":63.01,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:0)
164 S FDAIEN(1)=LRIDT
165 S FDA(63,LRX,"+1,"_LRDFN_",",.01)=LRCDT
166 S FDA(63,LRX,"+1,"_LRDFN_",",.06)=LRACC
167 I LRSS'="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.1)=LRNT
168 I LRSS="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.12)=3
169 I LRSS="MI" S FDA(63,LRX,"+1,"_LRDFN_",",38)=3
170 I LRX D UPDATE^DIE("","FDA(63)","FDAIEN","LRDIE(63)")
171 I $D(LRDIE(63)) D MAILALRT
172 ;
173 ; Uncomment following code when new field .9 in"MI" subscript is released
174 ;I LRSS="MI" D
175 ;. N LRN,ERR,IENS
176 ;. S IENS=LRIDT_","_LRDFN_",",LRN=0
177 ;. F S LRN=$O(^LRO(69,LRODT,1,LRSN,2,LRN)) Q:LRN<1 D
178 ;. . I '$D(^LRO(69,LRODT,1,LRSN,2,LRN,1,0)) Q
179 ;. . D WP^DIE(63.05,IENS,.9,"A","^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRN_",1)","ERR")
180 ;
181 L -^LR(LRDFN,LRSS,LRIDT,0)
182 ;
183 Q
184 ;
185 ;
186GTWLN ;
187 N X
188 ;
189 ; Execute accession transform for this area.
190 S LRAN=0
191 S X=$G(^LRO(68,LRWLC,.1)) X:X'="" X
192 ;
193 D GETLOCK(LRWLC,LRAD)
194 D CHECK68(LRWLC,LRAD)
195 ;
196 S:'LRAN LRAN=1+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3)
197 ;
198 I "CYEMSP"'[LRSS F Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN)) S LRAN=LRAN+1
199 ;
200 ; check for AP Accessions
201 I "CYEMSP"[LRSS F Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN))&'$D(^LR("A"_LRSS_"A",$E(LRAD,1,3),LRAN)) S LRAN=LRAN+1
202 ;
203 I '$D(LRPHSET),$D(LRNCWL)!$P(^LAB(69.9,1,0),U,8) D ASK Q:LREND
204 ;
205 D SETAN(LRWLC,LRAD,LRAN)
206 ;
207 L -^LRO(68,LRWLC,1,LRAD,1,0)
208 Q
209 ;
210 ;
211ASK ;
212 ; Don't ask if tasked or a "silent" call
213 I $D(ZTQUEUED)!($G(LRQUIET)) Q
214 ;
215 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LROK,LRANX,X,Y
216 S LROK=0
217 F D Q:LREND!(LROK)
218 . K DIR
219 . S DIR(0)="NO^1:"_$S($P(LRLABKY,U,2):999999,1:LRAN)_":0"
220 . S DIR("A")="Force to",DIR("B")=LRAN
221 . D ^DIR
222 . I $D(DIRUT) S LREND=1 Q
223 . S LRANX=Y
224 . I LRANX<+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3) D
225 . . W !,"This accession number may be already assigned either in this "
226 . . W !,"area or a common accession area."
227 . I $D(^LRO(68,LRWLC,1,LRAD,1,LRANX,0)) D Q:'LROK
228 . . N LRDFNX S LRDFNX=LRDFN
229 . . N DFN,LRDFN,LRDPF,PNM,SSN
230 . . S LRDFN=+^LRO(68,LRWLC,1,LRAD,1,LRANX,0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^LR(LRDFN,0),U,3)
231 . . D PT^LRX
232 . . W !,"THIS NUMBER BELONGS TO ",!,PNM," SSN: ",SSN
233 . . D INF^LRX
234 . . I LRDFN=LRDFNX S LROK=1
235 . K DIR
236 . S DIR(0)="YO",DIR("A")="Are you sure",DIR("B")="NO"
237 . D ^DIR
238 . I $D(DIRUT) S LREND=1 Q
239 . I Y=1 S LRAN=LRANX,LROK=1
240 ;
241 ; Unlock if aborting.
242 I LREND L -^LRO(68,LRWLC,1,LRAD,1,0)
243 ;
244 Q
245 ;
246 ;
247CHECK68(LRAA,LRAD) ; Check for/set header node of ^LRO(68) 68.01 subfile.
248 ;
249 ; Call with LRAA = ien of entry in file #68
250 ; LRAD = accession date in fileman format
251 ;
252 ; Set accession date in file #68 for this acession.
253 ; Check for existence of accession number multiple but not accession date multiple,
254 ; FileMan DBS call fails when accession number multiple exists but accession date multiple does not.
255 ; If this condition found then set missing node directly and quit.
256 ;
257 I '$D(^LRO(68,LRAA,1,LRAD,0)) D
258 . N FDA,FDAIEN,LRDIE,X
259 . S X=$Q(^LRO(68,LRAA,1,LRAD,0))
260 . I X'="",$QS(X,4)=LRAD S $P(^LRO(68,LRAA,1,LRAD,0),"^")=LRAD Q
261 . S (FDAIEN(1),FDA(1,68.01,"+1,"_LRAA_",",.01))=LRAD
262 . D UPDATE^DIE("","FDA(1)","FDAIEN","LRDIE(1)")
263 . I $D(LRDIE(1)) D MAILALRT
264 ;
265 Q
266 ;
267 ;
268GETLOCK(LRAA,LRAD) ; Obtain lock on zeroth node of this accession date
269 ; Call with LRAA = ien of entry in file #68
270 ; LRAD = accession date in fileman format
271 ;
272 F L +^LRO(68,LRAA,1,LRAD,1,0):10 Q:$T D
273 . I $D(ZTQUEUED)!($G(LRQUIET)) Q
274 . W !!?5,"Accession area ",$P(^LRO(68,LRAA,0),"^")," is locked by another user.",!,$C(7)
275 Q
276 ;
277 ;
278SETAN(LRAA,LRAD,LRAN) ; Create stub entry in file #68 for this acession.
279 ;
280 ; Call with LRAA = ien of entry in file #68
281 ; LRAD = accession date in fileman format
282 ; LRAN = accession number
283 ;
284 N FDA,FDAIEN,LR6802,LRDIE
285 ;
286 S LR6802=LRAD_","_LRAA_","
287 S FDAIEN(1)=LRAN
288 S FDA(2,68.02,"+1,"_LR6802,.01)=LRDFN
289 ;
290 ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
291 N LRLOCKOK,LRLOOPCT
292 S LRLOCKOK=0
293 F LRLOOPCT=1:1:10 Q:LRLOCKOK D I 'LRLOCKOK H 5
294 . K LRDIE(2)
295 . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
296 . S:$D(LRDIE(2))=0 LRLOCKOK=1
297 K LRLOCKOK,LRLOOPCT
298 ;
299 ;D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
300 I $D(LRDIE(2)) D MAILALRT
301 Q
302 ;
303 ;
304MAILALRT ; Send mail message alert when FileMan DBS errors returned
305 ;
306 N J,LR68,LRCNT,LRMTXT,X,XMINSTR,XMSUB,XMTO
307 ;
308 I $D(^LRO(68,LRAA,1,LRAD,1,LRAN)) M LR68=^LRO(68,LRAA,1,LRAD,1,LRAN)
309 ;
310 S LRMTXT(1)="The following debugging information is provided to assist"
311 S LRMTXT(2)="support staff in resolving error during accessioning."
312 S LRMTXT(3)=" "
313 S LRCNT=3
314 ;
315 F J="FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0" D
316 . S X=$G(@J)
317 . I X'="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_X
318 . F S J=$Q(@J) Q:J="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_@J
319 ;
320 S XMSUB="FileMan DBS call failed during accessioning in routine LRWLST1"
321 S XMTO("G.LMI")=""
322 S XMINSTR("FROM")=.5
323 S XMINSTR("ADDR FLAGS")="R"
324 D SENDMSG^XMXAPI(DUZ,XMSUB,"LRMTXT",.XMTO,.XMINSTR)
325 Q
Note: See TracBrowser for help on using the repository browser.