Merge lp:~joel-sher/openvista-gtm-integration/kidsbuild into lp:openvista-gtm-integration
- kidsbuild
- Merge into mainline
Proposed by
JSHER
Status: | Merged |
---|---|
Approved by: | JSHER |
Approved revision: | 23 |
Merged at revision: | not available |
Proposed branch: | lp:~joel-sher/openvista-gtm-integration/kidsbuild |
Merge into: | lp:openvista-gtm-integration |
Diff against target: | None lines |
To merge this branch: | bzr merge lp:~joel-sher/openvista-gtm-integration/kidsbuild |
Related bugs: |
Reviewer | Review Type | Date Requested | Status |
---|---|---|---|
JSHER | Approve | ||
Review via email: mp+6099@code.launchpad.net |
Commit message
Description of the change
To post a comment you must log in.
Revision history for this message
JSHER (joel-sher) : | # |
review:
Approve
Preview Diff
[H/L] Next/Prev Comment, [J/K] Next/Prev File, [N/P] Next/Prev Hunk
1 | === added directory 'kids' |
2 | === added file 'kids/MSCZJOB_6.KID' |
3 | --- kids/MSCZJOB_6.KID 1970-01-01 00:00:00 +0000 |
4 | +++ kids/MSCZJOB_6.KID 2009-04-17 17:48:03 +0000 |
5 | @@ -0,0 +1,6098 @@ |
6 | +KIDS Distribution saved on Apr 17, 2009@10:21:46 |
7 | +GTM CHANGES |
8 | +**KIDS**:MSCZJOB*0.1*6^ |
9 | + |
10 | +**INSTALL NAME** |
11 | +MSCZJOB*0.1*6 |
12 | +"BLD",6833,0) |
13 | +MSCZJOB*0.1*6^^0^3090417^y |
14 | +"BLD",6833,1,0) |
15 | +^^1^1^3070625^ |
16 | +"BLD",6833,1,1,0) |
17 | +SYSTEM STATUS AND JOBEXAM FOR GT.M |
18 | +"BLD",6833,4,0) |
19 | +^9.64PA^^ |
20 | +"BLD",6833,6.3) |
21 | +30 |
22 | +"BLD",6833,"KRN",0) |
23 | +^9.67PA^8989.52^19 |
24 | +"BLD",6833,"KRN",.4,0) |
25 | +.4 |
26 | +"BLD",6833,"KRN",.401,0) |
27 | +.401 |
28 | +"BLD",6833,"KRN",.402,0) |
29 | +.402 |
30 | +"BLD",6833,"KRN",.403,0) |
31 | +.403 |
32 | +"BLD",6833,"KRN",.403,"NM",0) |
33 | +^9.68A^2^2 |
34 | +"BLD",6833,"KRN",.403,"NM",1,0) |
35 | +MSCZJOBEXAM FILE #3.081^3.081^0 |
36 | +"BLD",6833,"KRN",.403,"NM",2,0) |
37 | +MSCZLOCK FILE #3.081^3.081^0 |
38 | +"BLD",6833,"KRN",.403,"NM","B","MSCZJOBEXAM FILE #3.081",1) |
39 | + |
40 | +"BLD",6833,"KRN",.403,"NM","B","MSCZLOCK FILE #3.081",2) |
41 | + |
42 | +"BLD",6833,"KRN",.5,0) |
43 | +.5 |
44 | +"BLD",6833,"KRN",.84,0) |
45 | +.84 |
46 | +"BLD",6833,"KRN",3.6,0) |
47 | +3.6 |
48 | +"BLD",6833,"KRN",3.8,0) |
49 | +3.8 |
50 | +"BLD",6833,"KRN",9.2,0) |
51 | +9.2 |
52 | +"BLD",6833,"KRN",9.8,0) |
53 | +9.8 |
54 | +"BLD",6833,"KRN",9.8,"NM",0) |
55 | +^9.68A^25^19 |
56 | +"BLD",6833,"KRN",9.8,"NM",1,0) |
57 | +MSCZJOB^^0^B12797960 |
58 | +"BLD",6833,"KRN",9.8,"NM",4,0) |
59 | +MSCZJOBU^^0^B3546679 |
60 | +"BLD",6833,"KRN",9.8,"NM",5,0) |
61 | +ZIS4GTM^^0^B18414491 |
62 | +"BLD",6833,"KRN",9.8,"NM",7,0) |
63 | +XTER1A^^0^B29045171 |
64 | +"BLD",6833,"KRN",9.8,"NM",8,0) |
65 | +ZU^^0^B9872646 |
66 | +"BLD",6833,"KRN",9.8,"NM",11,0) |
67 | +ZCD^^0^B5581 |
68 | +"BLD",6833,"KRN",9.8,"NM",13,0) |
69 | +ZOSV2GTM^^0^B6700455 |
70 | +"BLD",6833,"KRN",9.8,"NM",14,0) |
71 | +ZOSFGUX^^0^B22117954 |
72 | +"BLD",6833,"KRN",9.8,"NM",15,0) |
73 | +ZISHGUX^^0^B37875330 |
74 | +"BLD",6833,"KRN",9.8,"NM",16,0) |
75 | +HLCSTCP1^^0^B29662559 |
76 | +"BLD",6833,"KRN",9.8,"NM",17,0) |
77 | +HLCSTCP^^0^B32199902 |
78 | +"BLD",6833,"KRN",9.8,"NM",18,0) |
79 | +HLCSLNCH^^0^B37355917 |
80 | +"BLD",6833,"KRN",9.8,"NM",19,0) |
81 | +XOBVLL^^0^B18038185 |
82 | +"BLD",6833,"KRN",9.8,"NM",20,0) |
83 | +XOBVRH^^0^B13028891 |
84 | +"BLD",6833,"KRN",9.8,"NM",21,0) |
85 | +XOBVSKT^^0^B19778790 |
86 | +"BLD",6833,"KRN",9.8,"NM",22,0) |
87 | +XOBVTCPL^^0^B13529543 |
88 | +"BLD",6833,"KRN",9.8,"NM",23,0) |
89 | +XWBTCPM^^0^B56160723 |
90 | +"BLD",6833,"KRN",9.8,"NM",24,0) |
91 | +ZTMGRSET^^0^B48490586 |
92 | +"BLD",6833,"KRN",9.8,"NM",25,0) |
93 | +ZISTCPS^^0^B18372148 |
94 | +"BLD",6833,"KRN",9.8,"NM","B","HLCSLNCH",18) |
95 | + |
96 | +"BLD",6833,"KRN",9.8,"NM","B","HLCSTCP",17) |
97 | + |
98 | +"BLD",6833,"KRN",9.8,"NM","B","HLCSTCP1",16) |
99 | + |
100 | +"BLD",6833,"KRN",9.8,"NM","B","MSCZJOB",1) |
101 | + |
102 | +"BLD",6833,"KRN",9.8,"NM","B","MSCZJOBU",4) |
103 | + |
104 | +"BLD",6833,"KRN",9.8,"NM","B","XOBVLL",19) |
105 | + |
106 | +"BLD",6833,"KRN",9.8,"NM","B","XOBVRH",20) |
107 | + |
108 | +"BLD",6833,"KRN",9.8,"NM","B","XOBVSKT",21) |
109 | + |
110 | +"BLD",6833,"KRN",9.8,"NM","B","XOBVTCPL",22) |
111 | + |
112 | +"BLD",6833,"KRN",9.8,"NM","B","XTER1A",7) |
113 | + |
114 | +"BLD",6833,"KRN",9.8,"NM","B","XWBTCPM",23) |
115 | + |
116 | +"BLD",6833,"KRN",9.8,"NM","B","ZCD",11) |
117 | + |
118 | +"BLD",6833,"KRN",9.8,"NM","B","ZIS4GTM",5) |
119 | + |
120 | +"BLD",6833,"KRN",9.8,"NM","B","ZISHGUX",15) |
121 | + |
122 | +"BLD",6833,"KRN",9.8,"NM","B","ZISTCPS",25) |
123 | + |
124 | +"BLD",6833,"KRN",9.8,"NM","B","ZOSFGUX",14) |
125 | + |
126 | +"BLD",6833,"KRN",9.8,"NM","B","ZOSV2GTM",13) |
127 | + |
128 | +"BLD",6833,"KRN",9.8,"NM","B","ZTMGRSET",24) |
129 | + |
130 | +"BLD",6833,"KRN",9.8,"NM","B","ZU",8) |
131 | + |
132 | +"BLD",6833,"KRN",19,0) |
133 | +19 |
134 | +"BLD",6833,"KRN",19,"NM",0) |
135 | +^9.68A^2^2 |
136 | +"BLD",6833,"KRN",19,"NM",1,0) |
137 | +MSCZJOB^^0 |
138 | +"BLD",6833,"KRN",19,"NM",2,0) |
139 | +MSCZLOCK^^0 |
140 | +"BLD",6833,"KRN",19,"NM","B","MSCZJOB",1) |
141 | + |
142 | +"BLD",6833,"KRN",19,"NM","B","MSCZLOCK",2) |
143 | + |
144 | +"BLD",6833,"KRN",19.1,0) |
145 | +19.1 |
146 | +"BLD",6833,"KRN",101,0) |
147 | +101 |
148 | +"BLD",6833,"KRN",409.61,0) |
149 | +409.61 |
150 | +"BLD",6833,"KRN",771,0) |
151 | +771 |
152 | +"BLD",6833,"KRN",870,0) |
153 | +870 |
154 | +"BLD",6833,"KRN",8989.51,0) |
155 | +8989.51 |
156 | +"BLD",6833,"KRN",8989.52,0) |
157 | +8989.52 |
158 | +"BLD",6833,"KRN",8994,0) |
159 | +8994 |
160 | +"BLD",6833,"KRN","B",.4,.4) |
161 | + |
162 | +"BLD",6833,"KRN","B",.401,.401) |
163 | + |
164 | +"BLD",6833,"KRN","B",.402,.402) |
165 | + |
166 | +"BLD",6833,"KRN","B",.403,.403) |
167 | + |
168 | +"BLD",6833,"KRN","B",.5,.5) |
169 | + |
170 | +"BLD",6833,"KRN","B",.84,.84) |
171 | + |
172 | +"BLD",6833,"KRN","B",3.6,3.6) |
173 | + |
174 | +"BLD",6833,"KRN","B",3.8,3.8) |
175 | + |
176 | +"BLD",6833,"KRN","B",9.2,9.2) |
177 | + |
178 | +"BLD",6833,"KRN","B",9.8,9.8) |
179 | + |
180 | +"BLD",6833,"KRN","B",19,19) |
181 | + |
182 | +"BLD",6833,"KRN","B",19.1,19.1) |
183 | + |
184 | +"BLD",6833,"KRN","B",101,101) |
185 | + |
186 | +"BLD",6833,"KRN","B",409.61,409.61) |
187 | + |
188 | +"BLD",6833,"KRN","B",771,771) |
189 | + |
190 | +"BLD",6833,"KRN","B",870,870) |
191 | + |
192 | +"BLD",6833,"KRN","B",8989.51,8989.51) |
193 | + |
194 | +"BLD",6833,"KRN","B",8989.52,8989.52) |
195 | + |
196 | +"BLD",6833,"KRN","B",8994,8994) |
197 | + |
198 | +"BLD",6833,"MSC") |
199 | +/home/jsher/MSCZJOB_6.KID |
200 | +"BLD",6833,"MSCOM") |
201 | +LOCKS ON SEPARATE PAGE, UNLOCK AND KILL IN GTM |
202 | +"KRN",.403,116,-1) |
203 | +0^1 |
204 | +"KRN",.403,116,0) |
205 | +MSCZJOBEXAM^ ^@^^3070530.1755^^^3.081^0^1^1 |
206 | +"KRN",.403,116,12) |
207 | + |
208 | +"KRN",.403,116,21) |
209 | + |
210 | +"KRN",.403,116,40,0) |
211 | +^.4031I^3^3 |
212 | +"KRN",.403,116,40,1,0) |
213 | +1^^1,1^^^1^17,80 |
214 | +"KRN",.403,116,40,1,1) |
215 | +Page 1 |
216 | +"KRN",.403,116,40,1,40,0) |
217 | +^.4032IP^427^2 |
218 | +"KRN",.403,116,40,1,40,426,0) |
219 | +MSCZJOBEXAM^4^3,2^e |
220 | +"KRN",.403,116,40,1,40,426,2) |
221 | +13^^u^^1 |
222 | +"KRN",.403,116,40,1,40,426,"COMP MUL") |
223 | +D COMPMUL^MSCZJOB |
224 | +"KRN",.403,116,40,1,40,426,"COMP MUL PTR") |
225 | + |
226 | +"KRN",.403,116,40,1,40,427,0) |
227 | +MSCZJOBEXAM HDR^1^1,2^d |
228 | +"KRN",.403,116,40,2,0) |
229 | +2^^1,1^^^1^18,79 |
230 | +"KRN",.403,116,40,2,1) |
231 | +Page 2 |
232 | +"KRN",.403,116,40,2,40,0) |
233 | +^.4032IP^431^3 |
234 | +"KRN",.403,116,40,2,40,428,0) |
235 | +MSCZJOBEXAM 2^1^1,1^e |
236 | +"KRN",.403,116,40,2,40,429,0) |
237 | +MSCZJOBVARS^3^8,3^e |
238 | +"KRN",.403,116,40,2,40,429,2) |
239 | +9^^f^^1 |
240 | +"KRN",.403,116,40,2,40,429,"COMP MUL") |
241 | +D COMPVARS^MSCZJOB |
242 | +"KRN",.403,116,40,2,40,431,0) |
243 | +MSCZJOBSTACK^4^3,3^e |
244 | +"KRN",.403,116,40,2,40,431,2) |
245 | +3^ |
246 | +"KRN",.403,116,40,2,40,431,"COMP MUL") |
247 | +D COMPSTK^MSCZJOB |
248 | +"KRN",.403,116,40,3,0) |
249 | +3^^4,4^^^1^15,70 |
250 | +"KRN",.403,116,40,3,1) |
251 | +Page 3 |
252 | +"KRN",.403,116,40,3,40,0) |
253 | +^.4032IP^430^1 |
254 | +"KRN",.403,116,40,3,40,430,0) |
255 | +MSCZJOBLOCKS^1^2,3^e |
256 | +"KRN",.403,116,40,3,40,430,2) |
257 | +6^ |
258 | +"KRN",.403,116,40,3,40,430,"COMP MUL") |
259 | +D COMPLKS^MSCZJOB |
260 | +"KRN",.403,116,21400) |
261 | +1 |
262 | +"KRN",.403,117,-1) |
263 | +0^2 |
264 | +"KRN",.403,117,0) |
265 | +MSCZLOCK^ ^@^^3070530.1755^^^3.081^0^1^1 |
266 | +"KRN",.403,117,40,0) |
267 | +^.4031I^1^1 |
268 | +"KRN",.403,117,40,1,0) |
269 | +1^^1,1^^^0^17,80 |
270 | +"KRN",.403,117,40,1,1) |
271 | +Page 1 |
272 | +"KRN",.403,117,40,1,40,0) |
273 | +^.4032IP^433^2 |
274 | +"KRN",.403,117,40,1,40,432,0) |
275 | +MSCZLOCKEXAM^4^3,2^e |
276 | +"KRN",.403,117,40,1,40,432,2) |
277 | +13^^u^^1 |
278 | +"KRN",.403,117,40,1,40,432,"COMP MUL") |
279 | +D COMPLK^MSCZJOB |
280 | +"KRN",.403,117,40,1,40,433,0) |
281 | +MSCZJOBLOCK HDR^1^1,1^d |
282 | +"KRN",.404,426,0) |
283 | +MSCZJOBEXAM^3.081 |
284 | +"KRN",.404,426,40,0) |
285 | +^.4044I^5^5 |
286 | +"KRN",.404,426,40,1,0) |
287 | +1^^2^^JOB NUMBER |
288 | +"KRN",.404,426,40,1,2) |
289 | +1,2^6 |
290 | +"KRN",.404,426,40,1,3) |
291 | +!M |
292 | +"KRN",.404,426,40,1,3.1) |
293 | +S Y=$$JOB^MSCZJOB(D0) S:Y=$J Y=Y_"*" |
294 | +"KRN",.404,426,40,1,4) |
295 | +^^^2 |
296 | +"KRN",.404,426,40,1,10) |
297 | +S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U) |
298 | +"KRN",.404,426,40,1,20) |
299 | +F |
300 | +"KRN",.404,426,40,2,0) |
301 | +2^^2^^DEVICE |
302 | +"KRN",.404,426,40,2,2) |
303 | +1,9^23 |
304 | +"KRN",.404,426,40,2,3) |
305 | +!M |
306 | +"KRN",.404,426,40,2,3.1) |
307 | +S Y=$$DEV^MSCZJOB(D0) |
308 | +"KRN",.404,426,40,2,4) |
309 | +^^^1 |
310 | +"KRN",.404,426,40,2,20) |
311 | +F |
312 | +"KRN",.404,426,40,3,0) |
313 | +4^^2^^NAMESPACE |
314 | +"KRN",.404,426,40,3,2) |
315 | +1,48^11 |
316 | +"KRN",.404,426,40,3,3) |
317 | +!M |
318 | +"KRN",.404,426,40,3,3.1) |
319 | +S Y=$$NSP^MSCZJOB(D0) |
320 | +"KRN",.404,426,40,3,4) |
321 | +^^^1 |
322 | +"KRN",.404,426,40,3,20) |
323 | +F |
324 | +"KRN",.404,426,40,4,0) |
325 | +5^^2^^ROUTINE |
326 | +"KRN",.404,426,40,4,2) |
327 | +1,60^18 |
328 | +"KRN",.404,426,40,4,3) |
329 | +!M |
330 | +"KRN",.404,426,40,4,3.1) |
331 | +S Y=$$ROUTINE^MSCZJOB(D0) |
332 | +"KRN",.404,426,40,4,4) |
333 | +^^^1 |
334 | +"KRN",.404,426,40,4,20) |
335 | +F^U |
336 | +"KRN",.404,426,40,5,0) |
337 | +3^^2^^USER |
338 | +"KRN",.404,426,40,5,2) |
339 | +1,33^14 |
340 | +"KRN",.404,426,40,5,3) |
341 | +!M |
342 | +"KRN",.404,426,40,5,3.1) |
343 | +S Y=$$USER^MSCZJOB(D0) |
344 | +"KRN",.404,426,40,5,4) |
345 | +^^^1 |
346 | +"KRN",.404,426,40,5,20) |
347 | +F |
348 | +"KRN",.404,427,0) |
349 | +MSCZJOBEXAM HDR^3.081^ |
350 | +"KRN",.404,427,40,0) |
351 | +^.4044I^2^2 |
352 | +"KRN",.404,427,40,1,0) |
353 | +1^Process Device User Namespace Routine ^1 |
354 | +"KRN",.404,427,40,1,2) |
355 | +^^2,1 |
356 | +"KRN",.404,427,40,2,0) |
357 | +2^!M^1 |
358 | +"KRN",.404,427,40,2,.1) |
359 | +S Y=$$GET1^DIQ(8989.3,1,.01) |
360 | +"KRN",.404,427,40,2,2) |
361 | +^^1,28 |
362 | +"KRN",.404,428,0) |
363 | +MSCZJOBEXAM 2^3.081 |
364 | +"KRN",.404,428,40,0) |
365 | +^.4044I^7^7 |
366 | +"KRN",.404,428,40,1,0) |
367 | +1^Job^2^^JOB NUMBER |
368 | +"KRN",.404,428,40,1,2) |
369 | +2,8^6^2,3 |
370 | +"KRN",.404,428,40,1,3) |
371 | +!M |
372 | +"KRN",.404,428,40,1,3.1) |
373 | +S Y=$$JOB^MSCZJOB(MSCJOBD0) |
374 | +"KRN",.404,428,40,1,20) |
375 | +N |
376 | +"KRN",.404,428,40,2,0) |
377 | +2^NSpace^2^^NAMESPACE |
378 | +"KRN",.404,428,40,2,2) |
379 | +2,24^11^2,16 |
380 | +"KRN",.404,428,40,2,3) |
381 | +!M |
382 | +"KRN",.404,428,40,2,3.1) |
383 | +S Y=$$NSP^MSCZJOB(MSCJOBD0) |
384 | +"KRN",.404,428,40,2,4) |
385 | +^^^2 |
386 | +"KRN",.404,428,40,2,20) |
387 | +F |
388 | +"KRN",.404,428,40,3,0) |
389 | +3^Routine^2 |
390 | +"KRN",.404,428,40,3,2) |
391 | +2,46^16^2,37 |
392 | +"KRN",.404,428,40,3,3) |
393 | +!M |
394 | +"KRN",.404,428,40,3,3.1) |
395 | +S Y=$$ROUTINE^MSCZJOB(MSCJOBD0) |
396 | +"KRN",.404,428,40,3,4) |
397 | +^^^2 |
398 | +"KRN",.404,428,40,3,20) |
399 | +F^U |
400 | +"KRN",.404,428,40,4,0) |
401 | +4^^2^^USER |
402 | +"KRN",.404,428,40,4,2) |
403 | +2,63^14 |
404 | +"KRN",.404,428,40,4,3) |
405 | +!M |
406 | +"KRN",.404,428,40,4,3.1) |
407 | +S Y=$$USER^MSCZJOB(MSCJOBD0) |
408 | +"KRN",.404,428,40,4,4) |
409 | +^^^2 |
410 | +"KRN",.404,428,40,4,20) |
411 | +F |
412 | +"KRN",.404,428,40,5,0) |
413 | +5^Device^2^^DEVICE |
414 | +"KRN",.404,428,40,5,2) |
415 | +3,24^38^3,16 |
416 | +"KRN",.404,428,40,5,3) |
417 | +!M |
418 | +"KRN",.404,428,40,5,3.1) |
419 | +S Y=$$DEV^MSCZJOB(MSCJOBD0) |
420 | +"KRN",.404,428,40,5,4) |
421 | +^^^1 |
422 | +"KRN",.404,428,40,5,20) |
423 | +F^U |
424 | +"KRN",.404,428,40,6,0) |
425 | +4.4^LOCKs^2^^LOCKS |
426 | +"KRN",.404,428,40,6,2) |
427 | +3,10^3^3,3 |
428 | +"KRN",.404,428,40,6,3) |
429 | +!M |
430 | +"KRN",.404,428,40,6,3.1) |
431 | +S Y=$$LOCKS^MSCZJOB |
432 | +"KRN",.404,428,40,6,10) |
433 | +S DDSSTACK=3 |
434 | +"KRN",.404,428,40,6,20) |
435 | +N |
436 | +"KRN",.404,428,40,7,0) |
437 | +6^KILL JOB?^2^^KILL |
438 | +"KRN",.404,428,40,7,2) |
439 | +3,74^3^3,63 |
440 | +"KRN",.404,428,40,7,13) |
441 | +N X,Y I DDSEXT="YES" D KILL^MSCZJOB(MSCJOBID) |
442 | +"KRN",.404,428,40,7,20) |
443 | +Y |
444 | +"KRN",.404,429,0) |
445 | +MSCZJOBVARS^3.081 |
446 | +"KRN",.404,429,40,0) |
447 | +^.4044I^3^3 |
448 | +"KRN",.404,429,40,1,0) |
449 | +1^^2^^VARIABLE NAME |
450 | +"KRN",.404,429,40,1,2) |
451 | +1,1^24 |
452 | +"KRN",.404,429,40,1,3) |
453 | +!M |
454 | +"KRN",.404,429,40,1,3.1) |
455 | +S Y=$P(@MSC@(MSCJOBID,"V",D0),"=") |
456 | +"KRN",.404,429,40,1,4) |
457 | +^^^2 |
458 | +"KRN",.404,429,40,1,20) |
459 | +F |
460 | +"KRN",.404,429,40,2,0) |
461 | +2^^2^^VALUE OF VARIABLE |
462 | +"KRN",.404,429,40,2,2) |
463 | +1,28^48 |
464 | +"KRN",.404,429,40,2,3) |
465 | +!M |
466 | +"KRN",.404,429,40,2,3.1) |
467 | +S Y=$P(@MSC@(MSCJOBID,"V",D0),"=",2,999) |
468 | +"KRN",.404,429,40,2,4) |
469 | +^^^2 |
470 | +"KRN",.404,429,40,2,20) |
471 | +F^U |
472 | +"KRN",.404,429,40,3,0) |
473 | +1.5^=^1 |
474 | +"KRN",.404,429,40,3,2) |
475 | +^^1,26 |
476 | +"KRN",.404,430,0) |
477 | +MSCZJOBLOCKS^3.081^ |
478 | +"KRN",.404,430,40,0) |
479 | +^.4044I^2^2 |
480 | +"KRN",.404,430,40,1,0) |
481 | +1^^2^^LOCKS |
482 | +"KRN",.404,430,40,1,2) |
483 | +2,1^47 |
484 | +"KRN",.404,430,40,1,3) |
485 | +!M |
486 | +"KRN",.404,430,40,1,3.1) |
487 | +S Y=@MSC@(MSCJOBID,"L",D0) |
488 | +"KRN",.404,430,40,1,4) |
489 | +^^^2 |
490 | +"KRN",.404,430,40,1,20) |
491 | +F^U |
492 | +"KRN",.404,430,40,2,0) |
493 | +2^UNLOCK?^2^^UNLOCK |
494 | +"KRN",.404,430,40,2,2) |
495 | +2,58^3^2,49^1 |
496 | +"KRN",.404,430,40,2,13) |
497 | +I DDSEXT="YES" D UNLOCK^MSCZJOB(D0) |
498 | +"KRN",.404,430,40,2,20) |
499 | +Y |
500 | +"KRN",.404,431,0) |
501 | +MSCZJOBSTACK^3.081 |
502 | +"KRN",.404,431,40,0) |
503 | +^.4044I^1^1 |
504 | +"KRN",.404,431,40,1,0) |
505 | +1^^2^^STACK |
506 | +"KRN",.404,431,40,1,2) |
507 | +2,1^75 |
508 | +"KRN",.404,431,40,1,3) |
509 | +!M |
510 | +"KRN",.404,431,40,1,3.1) |
511 | +S Y=$$STACK^MSCZJOB(D0) |
512 | +"KRN",.404,431,40,1,4) |
513 | +^^^2 |
514 | +"KRN",.404,431,40,1,20) |
515 | +F^U |
516 | +"KRN",.404,432,0) |
517 | +MSCZLOCKEXAM^3.081 |
518 | +"KRN",.404,432,40,0) |
519 | +^.4044I^5^5 |
520 | +"KRN",.404,432,40,1,0) |
521 | +1^^2^^JOB NUMBER |
522 | +"KRN",.404,432,40,1,2) |
523 | +1,2^6 |
524 | +"KRN",.404,432,40,1,3) |
525 | +!M |
526 | +"KRN",.404,432,40,1,3.1) |
527 | +S Y=$P($G(MSCZLK(D0)),U,5) S:Y=$J Y=Y_"*" |
528 | +"KRN",.404,432,40,1,4) |
529 | +^^^2 |
530 | +"KRN",.404,432,40,1,10) |
531 | +S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U) |
532 | +"KRN",.404,432,40,1,20) |
533 | +F |
534 | +"KRN",.404,432,40,2,0) |
535 | +2^^2^^LOCK |
536 | +"KRN",.404,432,40,2,2) |
537 | +1,9^23 |
538 | +"KRN",.404,432,40,2,3) |
539 | +!M |
540 | +"KRN",.404,432,40,2,3.1) |
541 | +S Y=$TR($P($G(MSCZLK(D0)),U),"~") |
542 | +"KRN",.404,432,40,2,4) |
543 | +^^^1 |
544 | +"KRN",.404,432,40,2,20) |
545 | +F |
546 | +"KRN",.404,432,40,3,0) |
547 | +4^^2^^ROUTINE |
548 | +"KRN",.404,432,40,3,2) |
549 | +1,48^25 |
550 | +"KRN",.404,432,40,3,3) |
551 | +!M |
552 | +"KRN",.404,432,40,3,3.1) |
553 | +S Y=$TR($P($G(MSCZLK(D0)),U,3),$C(126),U) |
554 | +"KRN",.404,432,40,3,4) |
555 | +^^^1 |
556 | +"KRN",.404,432,40,3,20) |
557 | +F^U |
558 | +"KRN",.404,432,40,4,0) |
559 | +5^^2^^UNLOCK |
560 | +"KRN",.404,432,40,4,2) |
561 | +1,76^3 |
562 | +"KRN",.404,432,40,4,3) |
563 | +!M |
564 | +"KRN",.404,432,40,4,4) |
565 | +^^^0 |
566 | +"KRN",.404,432,40,4,13) |
567 | +I DDSEXT="YES" D UNL^MSCZJOB(D0) |
568 | +"KRN",.404,432,40,4,20) |
569 | +Y^U |
570 | +"KRN",.404,432,40,5,0) |
571 | +3^^2^^USER |
572 | +"KRN",.404,432,40,5,2) |
573 | +1,33^14 |
574 | +"KRN",.404,432,40,5,3) |
575 | +!M |
576 | +"KRN",.404,432,40,5,3.1) |
577 | +S Y=$P($G(MSCZLK(D0)),U,2) |
578 | +"KRN",.404,432,40,5,4) |
579 | +^^^1 |
580 | +"KRN",.404,432,40,5,20) |
581 | +F |
582 | +"KRN",.404,433,0) |
583 | +MSCZJOBLOCK HDR^3.081 |
584 | +"KRN",.404,433,40,0) |
585 | +^.4044I^2^2 |
586 | +"KRN",.404,433,40,1,0) |
587 | +1^Process Lock User Routine Unlock^1 |
588 | +"KRN",.404,433,40,1,2) |
589 | +^^2,1 |
590 | +"KRN",.404,433,40,2,0) |
591 | +2^!M^1 |
592 | +"KRN",.404,433,40,2,.1) |
593 | +S Y=$$GET1^DIQ(8989.3,1,.01) |
594 | +"KRN",.404,433,40,2,2) |
595 | +^^1,28 |
596 | +"KRN",19,13155,-1) |
597 | +0^1 |
598 | +"KRN",19,13155,0) |
599 | +MSCZJOB^JOB EXAMINE^^R^^^^^^^^ |
600 | +"KRN",19,13155,1,0) |
601 | +^^1^1^3070623^ |
602 | +"KRN",19,13155,1,1,0) |
603 | +DESIGNED FOR GT.M |
604 | +"KRN",19,13155,25) |
605 | +MSCZJOB |
606 | +"KRN",19,13155,"U") |
607 | +JOB EXAMINE |
608 | +"KRN",19,13162,-1) |
609 | +0^2 |
610 | +"KRN",19,13162,0) |
611 | +MSCZLOCK^LOCK EXAMINE^^R^^^^^^^^ |
612 | +"KRN",19,13162,1,0) |
613 | +^^1^1^3070623^ |
614 | +"KRN",19,13162,1,1,0) |
615 | +DESIGNED FOR GT.M |
616 | +"KRN",19,13162,25) |
617 | +LOCK^MSCZJOB |
618 | +"KRN",19,13162,"U") |
619 | +LOCK EXAMINE |
620 | +"MBREQ") |
621 | +0 |
622 | +"ORD",8,.403) |
623 | +.403;8;;;EDEOUT^DIFROMSO(.403,DA,"",XPDA);FPRE^DIFROMSI(.403,"",XPDA);EPRE^DIFROMSI(.403,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.403,DA,"",XPDA);DEL^DIFROMSK(.403,"",%) |
624 | +"ORD",8,.403,0) |
625 | +FORM |
626 | +"ORD",18,19) |
627 | +19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA |
628 | +"ORD",18,19,0) |
629 | +OPTION |
630 | +"QUES","XPF1",0) |
631 | +Y |
632 | +"QUES","XPF1","??") |
633 | +^D REP^XPDH |
634 | +"QUES","XPF1","A") |
635 | +Shall I write over your |FLAG| File |
636 | +"QUES","XPF1","B") |
637 | +YES |
638 | +"QUES","XPF1","M") |
639 | +D XPF1^XPDIQ |
640 | +"QUES","XPF2",0) |
641 | +Y |
642 | +"QUES","XPF2","??") |
643 | +^D DTA^XPDH |
644 | +"QUES","XPF2","A") |
645 | +Want my data |FLAG| yours |
646 | +"QUES","XPF2","B") |
647 | +YES |
648 | +"QUES","XPF2","M") |
649 | +D XPF2^XPDIQ |
650 | +"QUES","XPI1",0) |
651 | +YO |
652 | +"QUES","XPI1","??") |
653 | +^D INHIBIT^XPDH |
654 | +"QUES","XPI1","A") |
655 | +Want KIDS to INHIBIT LOGONs during the install |
656 | +"QUES","XPI1","B") |
657 | +YES |
658 | +"QUES","XPI1","M") |
659 | +D XPI1^XPDIQ |
660 | +"QUES","XPM1",0) |
661 | +PO^VA(200,:EM |
662 | +"QUES","XPM1","??") |
663 | +^D MG^XPDH |
664 | +"QUES","XPM1","A") |
665 | +Enter the Coordinator for Mail Group '|FLAG|' |
666 | +"QUES","XPM1","B") |
667 | + |
668 | +"QUES","XPM1","M") |
669 | +D XPM1^XPDIQ |
670 | +"QUES","XPO1",0) |
671 | +Y |
672 | +"QUES","XPO1","??") |
673 | +^D MENU^XPDH |
674 | +"QUES","XPO1","A") |
675 | +Want KIDS to Rebuild Menu Trees Upon Completion of Install |
676 | +"QUES","XPO1","B") |
677 | +YES |
678 | +"QUES","XPO1","M") |
679 | +D XPO1^XPDIQ |
680 | +"QUES","XPZ1",0) |
681 | +Y |
682 | +"QUES","XPZ1","??") |
683 | +^D OPT^XPDH |
684 | +"QUES","XPZ1","A") |
685 | +Want to DISABLE Scheduled Options, Menu Options, and Protocols |
686 | +"QUES","XPZ1","B") |
687 | +YES |
688 | +"QUES","XPZ1","M") |
689 | +D XPZ1^XPDIQ |
690 | +"QUES","XPZ2",0) |
691 | +Y |
692 | +"QUES","XPZ2","??") |
693 | +^D RTN^XPDH |
694 | +"QUES","XPZ2","A") |
695 | +Want to MOVE routines to other CPUs |
696 | +"QUES","XPZ2","B") |
697 | +NO |
698 | +"QUES","XPZ2","M") |
699 | +D XPZ2^XPDIQ |
700 | +"RTN") |
701 | +19 |
702 | +"RTN","HLCSLNCH") |
703 | +0^18^B37355917 |
704 | +"RTN","HLCSLNCH",1,0) |
705 | +HLCSLNCH ;ALB/MTC/JC MSC/JDA - START AND STOP THE LLP ;12/31/2003 17:37 |
706 | +"RTN","HLCSLNCH",2,0) |
707 | + ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,MSC**;Oct 13, 1995 |
708 | +"RTN","HLCSLNCH",3,0) |
709 | + ; |
710 | +"RTN","HLCSLNCH",4,0) |
711 | + ;This program is callable from a menu |
712 | +"RTN","HLCSLNCH",5,0) |
713 | + ;It allows the user to Start and Stop the Lower Layer |
714 | +"RTN","HLCSLNCH",6,0) |
715 | + ;Protocol in the Background or in the foreground |
716 | +"RTN","HLCSLNCH",7,0) |
717 | + ; |
718 | +"RTN","HLCSLNCH",8,0) |
719 | + ;Required or Optional INPUT PARAMETERS |
720 | +"RTN","HLCSLNCH",9,0) |
721 | + ; None |
722 | +"RTN","HLCSLNCH",10,0) |
723 | + ; |
724 | +"RTN","HLCSLNCH",11,0) |
725 | + ; |
726 | +"RTN","HLCSLNCH",12,0) |
727 | + ;Output variables |
728 | +"RTN","HLCSLNCH",13,0) |
729 | + ; HLDP=IEN of Logical Link in file #870 |
730 | +"RTN","HLCSLNCH",14,0) |
731 | + ;(optional)HLTRACE=if SET it launches the LLP in the Foreground |
732 | +"RTN","HLCSLNCH",15,0) |
733 | + ;(optional) ZTSK=if defined LLP was launched in the |
734 | +"RTN","HLCSLNCH",16,0) |
735 | + ;background |
736 | +"RTN","HLCSLNCH",17,0) |
737 | + ; |
738 | +"RTN","HLCSLNCH",18,0) |
739 | + ; |
740 | +"RTN","HLCSLNCH",19,0) |
741 | +START ; Start up the lower level protocol |
742 | +"RTN","HLCSLNCH",20,0) |
743 | + N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLQUIT,HLTRACE |
744 | +"RTN","HLCSLNCH",21,0) |
745 | + N HLPARM0,HLPARM4,HLTYPTR,HLBGR,X,Y,ZTCPU,ZTSK,ZTRTN,ZTDESC |
746 | +"RTN","HLCSLNCH",22,0) |
747 | + W !!,"This option is used to launch the lower level protocol for the" |
748 | +"RTN","HLCSLNCH",23,0) |
749 | + W !,"appropriate device. Please select the node with which you want" |
750 | +"RTN","HLCSLNCH",24,0) |
751 | + W !,"to communicate",! |
752 | +"RTN","HLCSLNCH",25,0) |
753 | + S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ |
754 | +"RTN","HLCSLNCH",26,0) |
755 | + S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0) |
756 | +"RTN","HLCSLNCH",27,0) |
757 | + ;-- check if parameter have been setup |
758 | +"RTN","HLCSLNCH",28,0) |
759 | + ;-- check for LLP type |
760 | +"RTN","HLCSLNCH",29,0) |
761 | + I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ |
762 | +"RTN","HLCSLNCH",30,0) |
763 | + ;-- get TCP information |
764 | +"RTN","HLCSLNCH",31,0) |
765 | + S HLPARM4=$G(^HLCS(870,HLDP,400)) |
766 | +"RTN","HLCSLNCH",32,0) |
767 | + ;-- get routine (background job for LLP) |
768 | +"RTN","HLCSLNCH",33,0) |
769 | + S HLBGR=$G(^HLCS(869.1,HLTYPTR,100)) |
770 | +"RTN","HLCSLNCH",34,0) |
771 | + ;-- get environment check routine (HLQUIT should be defined in fails) |
772 | +"RTN","HLCSLNCH",35,0) |
773 | + S HLENV=$G(^HLCS(869.1,HLTYPTR,200)) |
774 | +"RTN","HLCSLNCH",36,0) |
775 | + ; |
776 | +"RTN","HLCSLNCH",37,0) |
777 | + I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ |
778 | +"RTN","HLCSLNCH",38,0) |
779 | + ; |
780 | +"RTN","HLCSLNCH",39,0) |
781 | + ;-- execute environment check routine if HLQUIT is defined then terminate |
782 | +"RTN","HLCSLNCH",40,0) |
783 | + I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ |
784 | +"RTN","HLCSLNCH",41,0) |
785 | + ;Multi-Servers, only enable the link if not OpenM |
786 | +"RTN","HLCSLNCH",42,0) |
787 | + I $P(HLPARM4,U,3)="M",$$NOTMULTI D G STARTQ |
788 | +"RTN","HLCSLNCH",43,0) |
789 | + . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP." |
790 | +"RTN","HLCSLNCH",44,0) |
791 | + . Q |
792 | +"RTN","HLCSLNCH",45,0) |
793 | + ; |
794 | +"RTN","HLCSLNCH",46,0) |
795 | + I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error" |
796 | +"RTN","HLCSLNCH",47,0) |
797 | + I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"." |
798 | +"RTN","HLCSLNCH",48,0) |
799 | + I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !" |
800 | +"RTN","HLCSLNCH",49,0) |
801 | + I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D G STARTQ |
802 | +"RTN","HLCSLNCH",50,0) |
803 | + . W !,$C(7),"NOTE: The lower level protocol for this application is already running." |
804 | +"RTN","HLCSLNCH",51,0) |
805 | + I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D G STARTQ |
806 | +"RTN","HLCSLNCH",52,0) |
807 | + .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number |
808 | +"RTN","HLCSLNCH",53,0) |
809 | + .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors |
810 | +"RTN","HLCSLNCH",54,0) |
811 | + .N HLJ,X |
812 | +"RTN","HLCSLNCH",55,0) |
813 | + .I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q |
814 | +"RTN","HLCSLNCH",56,0) |
815 | + .L +^HLCS(870,HLDP,0):2 |
816 | +"RTN","HLCSLNCH",57,0) |
817 | + .E W !,$C(7),"Unable to enable this LLP !" Q |
818 | +"RTN","HLCSLNCH",58,0) |
819 | + .S X="HLJ(870,"""_HLDP_","")" |
820 | +"RTN","HLCSLNCH",59,0) |
821 | + .S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0 |
822 | +"RTN","HLCSLNCH",60,0) |
823 | + .D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6*109 |
824 | +"RTN","HLCSLNCH",61,0) |
825 | + .L -^HLCS(870,HLDP,0) |
826 | +"RTN","HLCSLNCH",62,0) |
827 | + .W !,"This LLP has been enabled!" |
828 | +"RTN","HLCSLNCH",63,0) |
829 | + .Q |
830 | +"RTN","HLCSLNCH",64,0) |
831 | + I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",! |
832 | +"RTN","HLCSLNCH",65,0) |
833 | + ; |
834 | +"RTN","HLCSLNCH",66,0) |
835 | + W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT" |
836 | +"RTN","HLCSLNCH",67,0) |
837 | + S DIR("A")="Method for running the receiver" |
838 | +"RTN","HLCSLNCH",68,0) |
839 | + S DIR("B")="B" |
840 | +"RTN","HLCSLNCH",69,0) |
841 | + S DIR("?",1)="Enter F for Foreground (and trace)" |
842 | +"RTN","HLCSLNCH",70,0) |
843 | + S DIR("?",2)=" B for Background (normal) or" |
844 | +"RTN","HLCSLNCH",71,0) |
845 | + S DIR("?")=" Q to quit without starting the receiver" |
846 | +"RTN","HLCSLNCH",72,0) |
847 | + D ^DIR K DIR |
848 | +"RTN","HLCSLNCH",73,0) |
849 | + Q:(Y=U)!(Y="Q") |
850 | +"RTN","HLCSLNCH",74,0) |
851 | + ; |
852 | +"RTN","HLCSLNCH",75,0) |
853 | + S HLX=$G(^HLCS(870,HLDP,0)) |
854 | +"RTN","HLCSLNCH",76,0) |
855 | + ;-- foreground |
856 | +"RTN","HLCSLNCH",77,0) |
857 | + I Y="F" S HLTRACE=1 D G STARTQ |
858 | +"RTN","HLCSLNCH",78,0) |
859 | + . X HLBGR |
860 | +"RTN","HLCSLNCH",79,0) |
861 | + ;-- background |
862 | +"RTN","HLCSLNCH",80,0) |
863 | + I Y="B" D G STARTQ |
864 | +"RTN","HLCSLNCH",81,0) |
865 | + . S ZTRTN=$P(HLBGR," ",2),HLTRACE="",ZTIO="",ZTDTH=$H |
866 | +"RTN","HLCSLNCH",82,0) |
867 | + . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="" |
868 | +"RTN","HLCSLNCH",83,0) |
869 | + . D ^%ZTLOAD |
870 | +"RTN","HLCSLNCH",84,0) |
871 | + . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.") |
872 | +"RTN","HLCSLNCH",85,0) |
873 | + ; |
874 | +"RTN","HLCSLNCH",86,0) |
875 | + Q |
876 | +"RTN","HLCSLNCH",87,0) |
877 | + ; |
878 | +"RTN","HLCSLNCH",88,0) |
879 | + ; |
880 | +"RTN","HLCSLNCH",89,0) |
881 | +STARTQ ; |
882 | +"RTN","HLCSLNCH",90,0) |
883 | + I $G(POP) W !,?5,"-Unable to Open the Device !",!,!,?6,"Check that Port is Logged Out, and that the",!,?6,"Lower Level Protocol is not Already Running." |
884 | +"RTN","HLCSLNCH",91,0) |
885 | + Q |
886 | +"RTN","HLCSLNCH",92,0) |
887 | + ; |
888 | +"RTN","HLCSLNCH",93,0) |
889 | +STOP ; Shut down a lower level protocol.. |
890 | +"RTN","HLCSLNCH",94,0) |
891 | + N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLPARM0,HLPARM4,X,Y |
892 | +"RTN","HLCSLNCH",95,0) |
893 | + W !!,"This option is used to shut down the lower level protocol for the" |
894 | +"RTN","HLCSLNCH",96,0) |
895 | + W !,"appropriate device. Please select the link which you would" |
896 | +"RTN","HLCSLNCH",97,0) |
897 | + W !,"like to shutdown.",! |
898 | +"RTN","HLCSLNCH",98,0) |
899 | + S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0 |
900 | +"RTN","HLCSLNCH",99,0) |
901 | + S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400)) |
902 | +"RTN","HLCSLNCH",100,0) |
903 | + I $P(HLPARM4,U,3)="M",$$NOTMULTI D Q |
904 | +"RTN","HLCSLNCH",101,0) |
905 | + . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. UCX. You must use the external service to disable this LLP." |
906 | +"RTN","HLCSLNCH",102,0) |
907 | + . Q |
908 | +"RTN","HLCSLNCH",103,0) |
909 | + ; |
910 | +"RTN","HLCSLNCH",104,0) |
911 | + I $P(HLPARM0,U,15) W !,$C(7),"The lower level protocol is already ",$P(HLPARM0,U,5),"." Q |
912 | +"RTN","HLCSLNCH",105,0) |
913 | + I $P(HLPARM0,U,10) W !,$C(7),"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." |
914 | +"RTN","HLCSLNCH",106,0) |
915 | +STP1 ; |
916 | +"RTN","HLCSLNCH",107,0) |
917 | + W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR |
918 | +"RTN","HLCSLNCH",108,0) |
919 | + I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q |
920 | +"RTN","HLCSLNCH",109,0) |
921 | +S ; |
922 | +"RTN","HLCSLNCH",110,0) |
923 | + F L +^HLCS(870,HLDP,0):2 Q:$T |
924 | +"RTN","HLCSLNCH",111,0) |
925 | + ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown |
926 | +"RTN","HLCSLNCH",112,0) |
927 | + S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1 |
928 | +"RTN","HLCSLNCH",113,0) |
929 | + I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown" |
930 | +"RTN","HLCSLNCH",114,0) |
931 | + D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109 |
932 | +"RTN","HLCSLNCH",115,0) |
933 | + I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D |
934 | +"RTN","HLCSLNCH",116,0) |
935 | + . ;pass task number to stop listener |
936 | +"RTN","HLCSLNCH",117,0) |
937 | + . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12)) |
938 | +"RTN","HLCSLNCH",118,0) |
939 | + . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10) |
940 | +"RTN","HLCSLNCH",119,0) |
941 | + . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q |
942 | +"RTN","HLCSLNCH",120,0) |
943 | + . U IO W "**STOP**" |
944 | +"RTN","HLCSLNCH",121,0) |
945 | + . W ! |
946 | +"RTN","HLCSLNCH",122,0) |
947 | + . D CLOSE^%ZISTCP |
948 | +"RTN","HLCSLNCH",123,0) |
949 | + L -^HLCS(870,HLDP,0) |
950 | +"RTN","HLCSLNCH",124,0) |
951 | + W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down." |
952 | +"RTN","HLCSLNCH",125,0) |
953 | + Q |
954 | +"RTN","HLCSLNCH",126,0) |
955 | + ; |
956 | +"RTN","HLCSLNCH",127,0) |
957 | +NOTMULTI() ; Returns 1 if implementation can't run multithreaded listener |
958 | +"RTN","HLCSLNCH",128,0) |
959 | + Q:^%ZOSF("OS")["GT.M" 0 |
960 | +"RTN","HLCSLNCH",129,0) |
961 | + Q $S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") |
962 | +"RTN","HLCSLNCH",130,0) |
963 | +STOPQ Q |
964 | +"RTN","HLCSTCP") |
965 | +0^17^B32199902 |
966 | +"RTN","HLCSTCP",1,0) |
967 | +HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE MSC/JDA- (TCP/IP) MLLP ;12/31/2003 18:03 |
968 | +"RTN","HLCSTCP",2,0) |
969 | + ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,MSC**;Oct 13, 1995 |
970 | +"RTN","HLCSTCP",3,0) |
971 | + ; |
972 | +"RTN","HLCSTCP",4,0) |
973 | + ; This is an implementation of the HL7 Minimal Lower Layer Protocol |
974 | +"RTN","HLCSTCP",5,0) |
975 | + ; |
976 | +"RTN","HLCSTCP",6,0) |
977 | + ;taskman entry/startup option, HLDP defined in menu entry, |
978 | +"RTN","HLCSTCP",7,0) |
979 | + Q:'$D(HLDP) |
980 | +"RTN","HLCSTCP",8,0) |
981 | + N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL |
982 | +"RTN","HLCSTCP",9,0) |
983 | + ;HLCSOUT= 1-error |
984 | +"RTN","HLCSTCP",10,0) |
985 | + I '$$INIT D EXITS("Init Error") Q |
986 | +"RTN","HLCSTCP",11,0) |
987 | + ; Start the client |
988 | +"RTN","HLCSTCP",12,0) |
989 | + I $G(HLTCPCS)="C" D Q |
990 | +"RTN","HLCSTCP",13,0) |
991 | + . ; identify process for ^%SY |
992 | +"RTN","HLCSTCP",14,0) |
993 | + . D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15)) |
994 | +"RTN","HLCSTCP",15,0) |
995 | + . D ST1 |
996 | +"RTN","HLCSTCP",16,0) |
997 | + . F D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT) |
998 | +"RTN","HLCSTCP",17,0) |
999 | + . I $G(HLCSOUT)=1 D MON("Error") H 1 Q |
1000 | +"RTN","HLCSTCP",18,0) |
1001 | + . I $G(HLCSOUT)=2 D EXITS("Inactive") Q |
1002 | +"RTN","HLCSTCP",19,0) |
1003 | + . D EXITS("Shutdown") |
1004 | +"RTN","HLCSTCP",20,0) |
1005 | + ; |
1006 | +"RTN","HLCSTCP",21,0) |
1007 | + ; identify process for ^%SY |
1008 | +"RTN","HLCSTCP",22,0) |
1009 | + D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) |
1010 | +"RTN","HLCSTCP",23,0) |
1011 | + ;HLCSFAIL=1 port failed to open |
1012 | +"RTN","HLCSTCP",24,0) |
1013 | + S HLCSFAIL=1 |
1014 | +"RTN","HLCSTCP",25,0) |
1015 | + ;single threaded listener |
1016 | +"RTN","HLCSTCP",26,0) |
1017 | + I $G(HLTCPCS)="S" D Q |
1018 | +"RTN","HLCSTCP",27,0) |
1019 | + . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")") |
1020 | +"RTN","HLCSTCP",28,0) |
1021 | + . ;couldn't open listener port |
1022 | +"RTN","HLCSTCP",29,0) |
1023 | + . I HLCSFAIL D EXITS("Openfail") Q |
1024 | +"RTN","HLCSTCP",30,0) |
1025 | + ; |
1026 | +"RTN","HLCSTCP",31,0) |
1027 | + ;multi-threaded listener (OpenM or GT.M) |
1028 | +"RTN","HLCSTCP",32,0) |
1029 | + I $G(HLTCPCS)="M",(^%ZOSF("OS")["OpenM")!(^%ZOSF("OS")["GT.M") D Q |
1030 | +"RTN","HLCSTCP",33,0) |
1031 | + . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")") |
1032 | +"RTN","HLCSTCP",34,0) |
1033 | + Q |
1034 | +"RTN","HLCSTCP",35,0) |
1035 | + ; |
1036 | +"RTN","HLCSTCP",36,0) |
1037 | +SERVER(HLDP) ; single server using Taskman |
1038 | +"RTN","HLCSTCP",37,0) |
1039 | + S HLCSFAIL=0 |
1040 | +"RTN","HLCSTCP",38,0) |
1041 | + I '$$INIT D EXITS("Init error") Q |
1042 | +"RTN","HLCSTCP",39,0) |
1043 | + D ^HLCSTCP1 |
1044 | +"RTN","HLCSTCP",40,0) |
1045 | + I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q |
1046 | +"RTN","HLCSTCP",41,0) |
1047 | + Q:$G(HLCSOUT)=1 |
1048 | +"RTN","HLCSTCP",42,0) |
1049 | + D MON("Idle") |
1050 | +"RTN","HLCSTCP",43,0) |
1051 | + Q |
1052 | +"RTN","HLCSTCP",44,0) |
1053 | + ; |
1054 | +"RTN","HLCSTCP",45,0) |
1055 | +SERVERS(HLDP) ; Multi-threaded server using Taskman |
1056 | +"RTN","HLCSTCP",46,0) |
1057 | + I '$$INIT D EXITS("Init error") Q |
1058 | +"RTN","HLCSTCP",47,0) |
1059 | + G LISTEN |
1060 | +"RTN","HLCSTCP",48,0) |
1061 | + ; |
1062 | +"RTN","HLCSTCP",49,0) |
1063 | + ;multiple process servers, called from an external utility |
1064 | +"RTN","HLCSTCP",50,0) |
1065 | +MSM ;MSM entry point, called from User-Defined Services |
1066 | +"RTN","HLCSTCP",51,0) |
1067 | + ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the |
1068 | +"RTN","HLCSTCP",52,0) |
1069 | + ;HL7 Multi-Threaded SERVER |
1070 | +"RTN","HLCSTCP",53,0) |
1071 | + S (IO,IO(0))=$P |
1072 | +"RTN","HLCSTCP",54,0) |
1073 | + G LISTEN |
1074 | +"RTN","HLCSTCP",55,0) |
1075 | + ; |
1076 | +"RTN","HLCSTCP",56,0) |
1077 | +CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file, |
1078 | +"RTN","HLCSTCP",57,0) |
1079 | + ;listener, % = HLDP |
1080 | +"RTN","HLCSTCP",58,0) |
1081 | + I $G(%)="" D ^%ZTER Q |
1082 | +"RTN","HLCSTCP",59,0) |
1083 | + S (IO,IO(0))="SYS$NET",HLDP=% |
1084 | +"RTN","HLCSTCP",60,0) |
1085 | + ; **Cache'/VMS specific code** |
1086 | +"RTN","HLCSTCP",61,0) |
1087 | + O IO::5 E D MON("Openfail") Q |
1088 | +"RTN","HLCSTCP",62,0) |
1089 | + X "U IO:(::""-M"")" ;Packet mode like DSM |
1090 | +"RTN","HLCSTCP",63,0) |
1091 | + D LISTEN C IO Q |
1092 | +"RTN","HLCSTCP",64,0) |
1093 | + ; |
1094 | +"RTN","HLCSTCP",65,0) |
1095 | +EN ;vms ucx entry point, called from HLSEVEN.COM file, |
1096 | +"RTN","HLCSTCP",66,0) |
1097 | + ;listener, % = device^HLDP |
1098 | +"RTN","HLCSTCP",67,0) |
1099 | + I $G(%)="" D ^%ZTER Q |
1100 | +"RTN","HLCSTCP",68,0) |
1101 | + S (IO,IO(0))="SYS$NET",HLDP=$P(%,"^",2) |
1102 | +"RTN","HLCSTCP",69,0) |
1103 | + ; **VMS specific code, need to share device** |
1104 | +"RTN","HLCSTCP",70,0) |
1105 | + X "O IO:(TCPDEV):60" E D MON("Openfail") Q |
1106 | +"RTN","HLCSTCP",71,0) |
1107 | +LISTEN ; |
1108 | +"RTN","HLCSTCP",72,0) |
1109 | + N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL |
1110 | +"RTN","HLCSTCP",73,0) |
1111 | + I '$$INIT D ^%ZTER Q |
1112 | +"RTN","HLCSTCP",74,0) |
1113 | + ; identify process for ^%SY |
1114 | +"RTN","HLCSTCP",75,0) |
1115 | + D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) |
1116 | +"RTN","HLCSTCP",76,0) |
1117 | + ;HLLSTN used to identify a listener to tag MON |
1118 | +"RTN","HLCSTCP",77,0) |
1119 | + S HLLSTN=1 |
1120 | +"RTN","HLCSTCP",78,0) |
1121 | + ;increment job count, run server |
1122 | +"RTN","HLCSTCP",79,0) |
1123 | + D UPDT(1),^HLCSTCP1,EXITM |
1124 | +"RTN","HLCSTCP",80,0) |
1125 | + Q |
1126 | +"RTN","HLCSTCP",81,0) |
1127 | + ; |
1128 | +"RTN","HLCSTCP",82,0) |
1129 | +DCOPEN(HLDP) ;open direct connect - called from HLMA2 |
1130 | +"RTN","HLCSTCP",83,0) |
1131 | + Q:'$$INIT 0 |
1132 | +"RTN","HLCSTCP",84,0) |
1133 | + Q:HLTCPADD=""!(HLTCPORT="") 0 |
1134 | +"RTN","HLCSTCP",85,0) |
1135 | + Q:'$$OPEN^HLCSTCP2 0 |
1136 | +"RTN","HLCSTCP",86,0) |
1137 | + Q 1 |
1138 | +"RTN","HLCSTCP",87,0) |
1139 | + ; |
1140 | +"RTN","HLCSTCP",88,0) |
1141 | +INIT() ; Initialize Variables |
1142 | +"RTN","HLCSTCP",89,0) |
1143 | + ; HLDP should be set to the IEN or name of Logical Link, file 870 |
1144 | +"RTN","HLCSTCP",90,0) |
1145 | + S HLOS=$P($G(^%ZOSF("OS")),"^") |
1146 | +"RTN","HLCSTCP",91,0) |
1147 | + N DA,DIQUIET,DR,TMP,X,Y |
1148 | +"RTN","HLCSTCP",92,0) |
1149 | + S DIQUIET=1 |
1150 | +"RTN","HLCSTCP",93,0) |
1151 | + D DT^DICRW |
1152 | +"RTN","HLCSTCP",94,0) |
1153 | + I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0 |
1154 | +"RTN","HLCSTCP",95,0) |
1155 | + S DA=HLDP |
1156 | +"RTN","HLCSTCP",96,0) |
1157 | + S DR="200.02;200.021;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05" |
1158 | +"RTN","HLCSTCP",97,0) |
1159 | + D GETS^DIQ(870,DA,DR,"IN","TMP","TMP") |
1160 | +"RTN","HLCSTCP",98,0) |
1161 | + ; |
1162 | +"RTN","HLCSTCP",99,0) |
1163 | + I $D(TMP("DIERR")) QUIT 0 |
1164 | +"RTN","HLCSTCP",100,0) |
1165 | + ; -- re-transmit attempts |
1166 | +"RTN","HLCSTCP",101,0) |
1167 | + S HLDRETR=+$G(TMP(870,DA_",",200.02,"I")) |
1168 | +"RTN","HLCSTCP",102,0) |
1169 | + ; -- exceed re-transmit action |
1170 | +"RTN","HLCSTCP",103,0) |
1171 | + S HLRETRA=$G(TMP(870,DA_",",200.021,"I")) |
1172 | +"RTN","HLCSTCP",104,0) |
1173 | + ; -- block size |
1174 | +"RTN","HLCSTCP",105,0) |
1175 | + S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I")) |
1176 | +"RTN","HLCSTCP",106,0) |
1177 | + ; -- read timeout |
1178 | +"RTN","HLCSTCP",107,0) |
1179 | + S HLDREAD=+$G(TMP(870,DA_",",200.04,"I")) |
1180 | +"RTN","HLCSTCP",108,0) |
1181 | + ; -- ack timeout |
1182 | +"RTN","HLCSTCP",109,0) |
1183 | + S HLDBACK=+$G(TMP(870,DA_",",200.05,"I")) |
1184 | +"RTN","HLCSTCP",110,0) |
1185 | + ; -- uni-directional wait |
1186 | +"RTN","HLCSTCP",111,0) |
1187 | + S HLDWAIT=$G(TMP(870,DA_",",200.09,"I")) |
1188 | +"RTN","HLCSTCP",112,0) |
1189 | + ; -- tcp address |
1190 | +"RTN","HLCSTCP",113,0) |
1191 | + S HLTCPADD=$G(TMP(870,DA_",",400.01,"I")) |
1192 | +"RTN","HLCSTCP",114,0) |
1193 | + ; -- tcp port |
1194 | +"RTN","HLCSTCP",115,0) |
1195 | + S HLTCPORT=$G(TMP(870,DA_",",400.02,"I")) |
1196 | +"RTN","HLCSTCP",116,0) |
1197 | + ; -- tcp/ip service type |
1198 | +"RTN","HLCSTCP",117,0) |
1199 | + S HLTCPCS=$G(TMP(870,DA_",",400.03,"I")) |
1200 | +"RTN","HLCSTCP",118,0) |
1201 | + ; -- link persistence |
1202 | +"RTN","HLCSTCP",119,0) |
1203 | + S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I")) |
1204 | +"RTN","HLCSTCP",120,0) |
1205 | + ; -- retention |
1206 | +"RTN","HLCSTCP",121,0) |
1207 | + S HLTCPRET=$G(TMP(870,DA_",",400.05,"I")) |
1208 | +"RTN","HLCSTCP",122,0) |
1209 | + ; |
1210 | +"RTN","HLCSTCP",123,0) |
1211 | + ; -- set defaults in case something's not set |
1212 | +"RTN","HLCSTCP",124,0) |
1213 | + S:HLDREAD=0 HLDREAD=10 |
1214 | +"RTN","HLCSTCP",125,0) |
1215 | + S:HLDBACK=0 HLDBACK=60 |
1216 | +"RTN","HLCSTCP",126,0) |
1217 | + S:HLDBSIZE=0 HLDBSIZE=245 |
1218 | +"RTN","HLCSTCP",127,0) |
1219 | + S:HLDRETR=0 HLDRETR=5 |
1220 | +"RTN","HLCSTCP",128,0) |
1221 | + S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15) |
1222 | +"RTN","HLCSTCP",129,0) |
1223 | + ; |
1224 | +"RTN","HLCSTCP",130,0) |
1225 | + Q 1 |
1226 | +"RTN","HLCSTCP",131,0) |
1227 | + ; |
1228 | +"RTN","HLCSTCP",132,0) |
1229 | +ST1 ;record startup in 870 for single server |
1230 | +"RTN","HLCSTCP",133,0) |
1231 | + ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number |
1232 | +"RTN","HLCSTCP",134,0) |
1233 | + ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors |
1234 | +"RTN","HLCSTCP",135,0) |
1235 | + N HLJ,X |
1236 | +"RTN","HLCSTCP",136,0) |
1237 | + F L +^HLCS(870,HLDP,0):2 Q:$T |
1238 | +"RTN","HLCSTCP",137,0) |
1239 | + S X="HLJ(870,"""_HLDP_","")" |
1240 | +"RTN","HLCSTCP",138,0) |
1241 | + S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0 |
1242 | +"RTN","HLCSTCP",139,0) |
1243 | + I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC") |
1244 | +"RTN","HLCSTCP",140,0) |
1245 | + E S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"") |
1246 | +"RTN","HLCSTCP",141,0) |
1247 | + I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT |
1248 | +"RTN","HLCSTCP",142,0) |
1249 | + S:$G(ZTSK) @X@(11)=ZTSK |
1250 | +"RTN","HLCSTCP",143,0) |
1251 | + D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109 |
1252 | +"RTN","HLCSTCP",144,0) |
1253 | + L -^HLCS(870,HLDP,0) |
1254 | +"RTN","HLCSTCP",145,0) |
1255 | + Q |
1256 | +"RTN","HLCSTCP",146,0) |
1257 | + ; |
1258 | +"RTN","HLCSTCP",147,0) |
1259 | +MON(Y) ;Display current state & check for shutdown |
1260 | +"RTN","HLCSTCP",148,0) |
1261 | + ;don't display for multiple server |
1262 | +"RTN","HLCSTCP",149,0) |
1263 | + Q:$G(HLLSTN) |
1264 | +"RTN","HLCSTCP",150,0) |
1265 | + F L +^HLCS(870,HLDP,0):2 Q:$T |
1266 | +"RTN","HLCSTCP",151,0) |
1267 | + S $P(^HLCS(870,HLDP,0),U,5)=Y |
1268 | +"RTN","HLCSTCP",152,0) |
1269 | + L -^HLCS(870,HLDP,0) |
1270 | +"RTN","HLCSTCP",153,0) |
1271 | + Q:'$D(HLTRACE) |
1272 | +"RTN","HLCSTCP",154,0) |
1273 | + N X U IO(0) |
1274 | +"RTN","HLCSTCP",155,0) |
1275 | + W !,"IN State: ",Y |
1276 | +"RTN","HLCSTCP",156,0) |
1277 | + I '$$STOP D |
1278 | +"RTN","HLCSTCP",157,0) |
1279 | + . R !,"Type Q to Quit: ",X#1:1 |
1280 | +"RTN","HLCSTCP",158,0) |
1281 | + . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1 |
1282 | +"RTN","HLCSTCP",159,0) |
1283 | + U IO |
1284 | +"RTN","HLCSTCP",160,0) |
1285 | + Q |
1286 | +"RTN","HLCSTCP",161,0) |
1287 | +UPDT(Y) ;update job count for multiple servers,X=1 increment |
1288 | +"RTN","HLCSTCP",162,0) |
1289 | + N HLJ,X |
1290 | +"RTN","HLCSTCP",163,0) |
1291 | + F L +^HLCS(870,HLDP,0):2 Q:$T |
1292 | +"RTN","HLCSTCP",164,0) |
1293 | + S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server" |
1294 | +"RTN","HLCSTCP",165,0) |
1295 | + ;if incrementing, set the Device Type field to Multi-Server |
1296 | +"RTN","HLCSTCP",166,0) |
1297 | + I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109 |
1298 | +"RTN","HLCSTCP",167,0) |
1299 | + L -^HLCS(870,HLDP,0) |
1300 | +"RTN","HLCSTCP",168,0) |
1301 | + Q |
1302 | +"RTN","HLCSTCP",169,0) |
1303 | +STOP() ;stop flag set |
1304 | +"RTN","HLCSTCP",170,0) |
1305 | + N X |
1306 | +"RTN","HLCSTCP",171,0) |
1307 | + F L +^HLCS(870,HLDP,0):2 Q:$T |
1308 | +"RTN","HLCSTCP",172,0) |
1309 | + S X=+$P(^HLCS(870,HLDP,0),U,15) |
1310 | +"RTN","HLCSTCP",173,0) |
1311 | + L -^HLCS(870,HLDP,0) |
1312 | +"RTN","HLCSTCP",174,0) |
1313 | + Q X |
1314 | +"RTN","HLCSTCP",175,0) |
1315 | + ; |
1316 | +"RTN","HLCSTCP",176,0) |
1317 | +LLCNT(DP,Y,Z) ;update Logical Link counters |
1318 | +"RTN","HLCSTCP",177,0) |
1319 | + ;DP=ien of Logical Link in file 870 |
1320 | +"RTN","HLCSTCP",178,0) |
1321 | + ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent |
1322 | +"RTN","HLCSTCP",179,0) |
1323 | + ;Z: ""=add to counter, 1=subtract from counter |
1324 | +"RTN","HLCSTCP",180,0) |
1325 | + Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y)) |
1326 | +"RTN","HLCSTCP",181,0) |
1327 | + N P,X |
1328 | +"RTN","HLCSTCP",182,0) |
1329 | + S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER" |
1330 | +"RTN","HLCSTCP",183,0) |
1331 | + F L +^HLCS(870,DP,P):2 Q:$T |
1332 | +"RTN","HLCSTCP",184,0) |
1333 | + S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1) |
1334 | +"RTN","HLCSTCP",185,0) |
1335 | + L -^HLCS(870,DP,P) |
1336 | +"RTN","HLCSTCP",186,0) |
1337 | + Q |
1338 | +"RTN","HLCSTCP",187,0) |
1339 | +SDFLD ; set Shutdown? field to yes |
1340 | +"RTN","HLCSTCP",188,0) |
1341 | + Q:'$G(HLDP) |
1342 | +"RTN","HLCSTCP",189,0) |
1343 | + N HLJ,X |
1344 | +"RTN","HLCSTCP",190,0) |
1345 | + F L +^HLCS(870,HLDP,0):2 Q:$T |
1346 | +"RTN","HLCSTCP",191,0) |
1347 | + ;14=Shutdown LLP? |
1348 | +"RTN","HLCSTCP",192,0) |
1349 | + S HLJ(870,HLDP_",",14)=1 |
1350 | +"RTN","HLCSTCP",193,0) |
1351 | + D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109 |
1352 | +"RTN","HLCSTCP",194,0) |
1353 | + L -^HLCS(870,HLDP,0) |
1354 | +"RTN","HLCSTCP",195,0) |
1355 | + Q |
1356 | +"RTN","HLCSTCP",196,0) |
1357 | + ; |
1358 | +"RTN","HLCSTCP",197,0) |
1359 | +EXITS(Y) ; Single service shutdown and cleans up |
1360 | +"RTN","HLCSTCP",198,0) |
1361 | + N HLJ,X |
1362 | +"RTN","HLCSTCP",199,0) |
1363 | + F L +^HLCS(870,HLDP,0):2 Q:$T |
1364 | +"RTN","HLCSTCP",200,0) |
1365 | + ;4=status,10=Time Stopped,9=Time Started,11=Task Number |
1366 | +"RTN","HLCSTCP",201,0) |
1367 | + S X="HLJ(870,"""_HLDP_","")" |
1368 | +"RTN","HLCSTCP",202,0) |
1369 | + S @X@(4)=Y,@X@(11)="@" |
1370 | +"RTN","HLCSTCP",203,0) |
1371 | + S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@" |
1372 | +"RTN","HLCSTCP",204,0) |
1373 | + D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109 |
1374 | +"RTN","HLCSTCP",205,0) |
1375 | + L -^HLCS(870,HLDP,0) |
1376 | +"RTN","HLCSTCP",206,0) |
1377 | + I $D(ZTQUEUED) S ZTREQ="@" |
1378 | +"RTN","HLCSTCP",207,0) |
1379 | + Q |
1380 | +"RTN","HLCSTCP",208,0) |
1381 | + ; |
1382 | +"RTN","HLCSTCP",209,0) |
1383 | +EXITM ;Multiple service shutdown and clean up |
1384 | +"RTN","HLCSTCP",210,0) |
1385 | + D UPDT(0) |
1386 | +"RTN","HLCSTCP",211,0) |
1387 | + I $D(ZTQUEUED) S ZTREQ="@" |
1388 | +"RTN","HLCSTCP",212,0) |
1389 | + Q |
1390 | +"RTN","HLCSTCP1") |
1391 | +0^16^B29662559 |
1392 | +"RTN","HLCSTCP1",1,0) |
1393 | +HLCSTCP1 ;SFIRMFO/RSD MSC/JDA - BI-DIRECTIONAL TCP ;11/21/2001 17:09 |
1394 | +"RTN","HLCSTCP1",2,0) |
1395 | + ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,MSC**;JUL 17,1995 |
1396 | +"RTN","HLCSTCP1",3,0) |
1397 | + ;Receiver |
1398 | +"RTN","HLCSTCP1",4,0) |
1399 | + ;connection is initiated by sender and listener accepts connection |
1400 | +"RTN","HLCSTCP1",5,0) |
1401 | + ;and calls this routine |
1402 | +"RTN","HLCSTCP1",6,0) |
1403 | + ; |
1404 | +"RTN","HLCSTCP1",7,0) |
1405 | + N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1" |
1406 | +"RTN","HLCSTCP1",8,0) |
1407 | + N HLMIEN,HLASTMSG |
1408 | +"RTN","HLCSTCP1",9,0) |
1409 | + D MON^HLCSTCP("Open") |
1410 | +"RTN","HLCSTCP1",10,0) |
1411 | + K ^TMP("HLCSTCP",$J,0) |
1412 | +"RTN","HLCSTCP1",11,0) |
1413 | + S HLMIEN=0,HLASTMSG="" |
1414 | +"RTN","HLCSTCP1",12,0) |
1415 | + F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3 |
1416 | +"RTN","HLCSTCP1",13,0) |
1417 | + . S HLMIEN=$$READ |
1418 | +"RTN","HLCSTCP1",14,0) |
1419 | + . Q:'HLMIEN |
1420 | +"RTN","HLCSTCP1",15,0) |
1421 | + . D PROCESS |
1422 | +"RTN","HLCSTCP1",16,0) |
1423 | + Q |
1424 | +"RTN","HLCSTCP1",17,0) |
1425 | + ; |
1426 | +"RTN","HLCSTCP1",18,0) |
1427 | +PROCESS ;check message and reply |
1428 | +"RTN","HLCSTCP1",19,0) |
1429 | + ;HLDP=LL in 870, update monitor, received msg. |
1430 | +"RTN","HLCSTCP1",20,0) |
1431 | + N HLTCP,HLTCPI,HLTCPO |
1432 | +"RTN","HLCSTCP1",21,0) |
1433 | + S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN |
1434 | +"RTN","HLCSTCP1",22,0) |
1435 | + ;update monitor, msg. received |
1436 | +"RTN","HLCSTCP1",23,0) |
1437 | + D LLCNT^HLCSTCP(HLDP,1) |
1438 | +"RTN","HLCSTCP1",24,0) |
1439 | + D NEW^HLTP3(HLMIEN) |
1440 | +"RTN","HLCSTCP1",25,0) |
1441 | + ;update monitor, msg. processed |
1442 | +"RTN","HLCSTCP1",26,0) |
1443 | + D LLCNT^HLCSTCP(HLDP,2) |
1444 | +"RTN","HLCSTCP1",27,0) |
1445 | + Q |
1446 | +"RTN","HLCSTCP1",28,0) |
1447 | + ; |
1448 | +"RTN","HLCSTCP1",29,0) |
1449 | +READ() ;read 1 message, returns ien in 773^ien in 772 for message |
1450 | +"RTN","HLCSTCP1",30,0) |
1451 | + D MON^HLCSTCP("Reading") |
1452 | +"RTN","HLCSTCP1",31,0) |
1453 | + N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X |
1454 | +"RTN","HLCSTCP1",32,0) |
1455 | + ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator |
1456 | +"RTN","HLCSTCP1",33,0) |
1457 | + S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13) |
1458 | +"RTN","HLCSTCP1",34,0) |
1459 | + ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772 |
1460 | +"RTN","HLCSTCP1",35,0) |
1461 | + ;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack |
1462 | +"RTN","HLCSTCP1",36,0) |
1463 | + S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK |
1464 | +"RTN","HLCSTCP1",37,0) |
1465 | + K ^TMP("HLCSTCP",$J,0) |
1466 | +"RTN","HLCSTCP1",38,0) |
1467 | + F D RDBLK Q:HLRDOUT |
1468 | +"RTN","HLCSTCP1",39,0) |
1469 | + ;save any excess for next time |
1470 | +"RTN","HLCSTCP1",40,0) |
1471 | + S:$L(HLX) ^TMP("HLCSTCP",$J,0)=HLX |
1472 | +"RTN","HLCSTCP1",41,0) |
1473 | + I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0 |
1474 | +"RTN","HLCSTCP1",42,0) |
1475 | + Q HLIND1 |
1476 | +"RTN","HLCSTCP1",43,0) |
1477 | + ; |
1478 | +"RTN","HLCSTCP1",44,0) |
1479 | +RDBLK S HLDB=HLDBSIZE-$L(HLX) |
1480 | +"RTN","HLCSTCP1",45,0) |
1481 | + U IO D:$D ERROR R X#HLDB:HLDREAD ; MSC/JDA added check against $d |
1482 | +"RTN","HLCSTCP1",46,0) |
1483 | + ; timedout or error, check ack timeout, clean up |
1484 | +"RTN","HLCSTCP1",47,0) |
1485 | + I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q |
1486 | +"RTN","HLCSTCP1",48,0) |
1487 | + ;data stream: <sb>dddd<cr><eb><cr> |
1488 | +"RTN","HLCSTCP1",49,0) |
1489 | + ;add incoming line to what wasn't processed in last read |
1490 | +"RTN","HLCSTCP1",50,0) |
1491 | + S HLX=$G(HLX)_X |
1492 | +"RTN","HLCSTCP1",51,0) |
1493 | + ; look for segment= <CR> |
1494 | +"RTN","HLCSTCP1",52,0) |
1495 | + F Q:HLX'[HLRS D Q:HLRDOUT |
1496 | +"RTN","HLCSTCP1",53,0) |
1497 | + . ; Get the first piece, save the rest of the line |
1498 | +"RTN","HLCSTCP1",54,0) |
1499 | + . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999) |
1500 | +"RTN","HLCSTCP1",55,0) |
1501 | + . ; check for start block, Quit if no ien |
1502 | +"RTN","HLCSTCP1",56,0) |
1503 | + . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D Q |
1504 | +"RTN","HLCSTCP1",57,0) |
1505 | + .. D:HLMSG(HLINE,0)[HLDSTRT |
1506 | +"RTN","HLCSTCP1",58,0) |
1507 | + ... S X=$L(HLMSG(HLINE,0),HLDSTRT) |
1508 | +"RTN","HLCSTCP1",59,0) |
1509 | + ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X) |
1510 | +"RTN","HLCSTCP1",60,0) |
1511 | + ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2) |
1512 | +"RTN","HLCSTCP1",61,0) |
1513 | + ... D RESET:(HLINE>1) |
1514 | +"RTN","HLCSTCP1",62,0) |
1515 | + .. ;ping message |
1516 | +"RTN","HLCSTCP1",63,0) |
1517 | + .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q |
1518 | +"RTN","HLCSTCP1",64,0) |
1519 | + .. ; get next ien to store |
1520 | +"RTN","HLCSTCP1",65,0) |
1521 | + .. D MIEN |
1522 | +"RTN","HLCSTCP1",66,0) |
1523 | + .. K HLMSG |
1524 | +"RTN","HLCSTCP1",67,0) |
1525 | + .. S (HLINE,HLHDR)=0 |
1526 | +"RTN","HLCSTCP1",68,0) |
1527 | + . ; check for end block; HLMSG(HLINE) = <eb><cr> |
1528 | +"RTN","HLCSTCP1",69,0) |
1529 | + . I HLMSG(HLINE,0)[HLDEND D |
1530 | +"RTN","HLCSTCP1",70,0) |
1531 | + .. ;no msg. ien |
1532 | +"RTN","HLCSTCP1",71,0) |
1533 | + .. Q:'HLIND1 |
1534 | +"RTN","HLCSTCP1",72,0) |
1535 | + .. ; Kill just the last line |
1536 | +"RTN","HLCSTCP1",73,0) |
1537 | + .. K HLMSG(HLINE,0) S HLINE=HLINE-1 |
1538 | +"RTN","HLCSTCP1",74,0) |
1539 | + .. ; move into 772 |
1540 | +"RTN","HLCSTCP1",75,0) |
1541 | + .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")") |
1542 | +"RTN","HLCSTCP1",76,0) |
1543 | + .. ;mark that end block has been received |
1544 | +"RTN","HLCSTCP1",77,0) |
1545 | + .. ;HLIND1=ien in 773^ien in 772^1 if end block was received |
1546 | +"RTN","HLCSTCP1",78,0) |
1547 | + .. S $P(HLIND1,U,3)=1 |
1548 | +"RTN","HLCSTCP1",79,0) |
1549 | + .. ;reset variables for next message |
1550 | +"RTN","HLCSTCP1",80,0) |
1551 | + .. D CLEAN |
1552 | +"RTN","HLCSTCP1",81,0) |
1553 | + . ;add blank line for carriage return |
1554 | +"RTN","HLCSTCP1",82,0) |
1555 | + . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)="" |
1556 | +"RTN","HLCSTCP1",83,0) |
1557 | + Q:HLRDOUT |
1558 | +"RTN","HLCSTCP1",84,0) |
1559 | + ;If the line is long and no <CR> move it into the array. |
1560 | +"RTN","HLCSTCP1",85,0) |
1561 | + I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D Q |
1562 | +"RTN","HLCSTCP1",86,0) |
1563 | + . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX="" |
1564 | +"RTN","HLCSTCP1",87,0) |
1565 | + ;have start block but no record seperator |
1566 | +"RTN","HLCSTCP1",88,0) |
1567 | + I HLX[HLDSTRT D Q |
1568 | +"RTN","HLCSTCP1",89,0) |
1569 | + . ;check for more than 1 start block |
1570 | +"RTN","HLCSTCP1",90,0) |
1571 | + . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X) |
1572 | +"RTN","HLCSTCP1",91,0) |
1573 | + . S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1 |
1574 | +"RTN","HLCSTCP1",92,0) |
1575 | + . D RESET:(HLHDR&(HLINE>1)) |
1576 | +"RTN","HLCSTCP1",93,0) |
1577 | + ;if no ien, then we don't have start block, reset |
1578 | +"RTN","HLCSTCP1",94,0) |
1579 | + I 'HLIND1 D CLEAN Q |
1580 | +"RTN","HLCSTCP1",95,0) |
1581 | + ; big message-merge from local to global every 100 lines |
1582 | +"RTN","HLCSTCP1",96,0) |
1583 | + I (HLINE-$O(HLMSG(0)))>100 D |
1584 | +"RTN","HLCSTCP1",97,0) |
1585 | + . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG |
1586 | +"RTN","HLCSTCP1",98,0) |
1587 | + . ; reset working array |
1588 | +"RTN","HLCSTCP1",99,0) |
1589 | + . K HLMSG |
1590 | +"RTN","HLCSTCP1",100,0) |
1591 | + Q |
1592 | +"RTN","HLCSTCP1",101,0) |
1593 | + ; |
1594 | +"RTN","HLCSTCP1",102,0) |
1595 | +SAVE(SRC,DEST) ;save into global & set top node |
1596 | +"RTN","HLCSTCP1",103,0) |
1597 | + ;SRC=source array (passed by ref.), DEST=destination global |
1598 | +"RTN","HLCSTCP1",104,0) |
1599 | + M @DEST=SRC |
1600 | +"RTN","HLCSTCP1",105,0) |
1601 | + S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^" |
1602 | +"RTN","HLCSTCP1",106,0) |
1603 | + Q |
1604 | +"RTN","HLCSTCP1",107,0) |
1605 | + ; |
1606 | +"RTN","HLCSTCP1",108,0) |
1607 | +DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files. |
1608 | +"RTN","HLCSTCP1",109,0) |
1609 | + N DIK,DA |
1610 | +"RTN","HLCSTCP1",110,0) |
1611 | + S DA=+HLMAMT,DIK="^HLMA(" |
1612 | +"RTN","HLCSTCP1",111,0) |
1613 | + D ^DIK |
1614 | +"RTN","HLCSTCP1",112,0) |
1615 | + S DA=$P(HLMAMT,U,2),DIK="^HL(772," |
1616 | +"RTN","HLCSTCP1",113,0) |
1617 | + D ^DIK |
1618 | +"RTN","HLCSTCP1",114,0) |
1619 | + Q |
1620 | +"RTN","HLCSTCP1",115,0) |
1621 | +MIEN ; sets HLIND1=ien in 773^ien in 772 for message |
1622 | +"RTN","HLCSTCP1",116,0) |
1623 | + N HLMID,X |
1624 | +"RTN","HLCSTCP1",117,0) |
1625 | + I HLIND1 D |
1626 | +"RTN","HLCSTCP1",118,0) |
1627 | + . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0 |
1628 | +"RTN","HLCSTCP1",119,0) |
1629 | + . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0 |
1630 | +"RTN","HLCSTCP1",120,0) |
1631 | + ;msg. id is 10th of MSH & 11th for BSH or FSH |
1632 | +"RTN","HLCSTCP1",121,0) |
1633 | + S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X) |
1634 | +"RTN","HLCSTCP1",122,0) |
1635 | + ;if HLIND1 is set, kill old message, use HLIND1 for new |
1636 | +"RTN","HLCSTCP1",123,0) |
1637 | + ;message, it means we never got end block for 1st msg. |
1638 | +"RTN","HLCSTCP1",124,0) |
1639 | + I HLIND1 D Q |
1640 | +"RTN","HLCSTCP1",125,0) |
1641 | + . ;get pointer to 772, kill header |
1642 | +"RTN","HLCSTCP1",126,0) |
1643 | + . K ^HLMA(+HLIND1,"MSH") |
1644 | +"RTN","HLCSTCP1",127,0) |
1645 | + . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN") |
1646 | +"RTN","HLCSTCP1",128,0) |
1647 | + . S X=$$MAID^HLTF(+HLIND1,HLMID) |
1648 | +"RTN","HLCSTCP1",129,0) |
1649 | + . D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") |
1650 | +"RTN","HLCSTCP1",130,0) |
1651 | + . S:$P(HLIND1,U,3) $P(HLIND1,U,3)="" |
1652 | +"RTN","HLCSTCP1",131,0) |
1653 | + D TCP^HLTF(.HLMID,.X,.HLDT) |
1654 | +"RTN","HLCSTCP1",132,0) |
1655 | + I 'X D Q |
1656 | +"RTN","HLCSTCP1",133,0) |
1657 | + . ;error - record and reset array |
1658 | +"RTN","HLCSTCP1",134,0) |
1659 | + . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server |
1660 | +"RTN","HLCSTCP1",135,0) |
1661 | + . D CLEAN K HLLSTN |
1662 | +"RTN","HLCSTCP1",136,0) |
1663 | + . ;error 100=LLP Could not Enqueue the Message, reset array |
1664 | +"RTN","HLCSTCP1",137,0) |
1665 | + . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30 |
1666 | +"RTN","HLCSTCP1",138,0) |
1667 | + ;HLIND1=ien in 773^ien in 772 |
1668 | +"RTN","HLCSTCP1",139,0) |
1669 | + S HLIND1=X_U_+$G(^HLMA(X,0)) |
1670 | +"RTN","HLCSTCP1",140,0) |
1671 | + ;save MSH into 773 |
1672 | +"RTN","HLCSTCP1",141,0) |
1673 | + D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") |
1674 | +"RTN","HLCSTCP1",142,0) |
1675 | + Q |
1676 | +"RTN","HLCSTCP1",143,0) |
1677 | + ; |
1678 | +"RTN","HLCSTCP1",144,0) |
1679 | +PMSH(MSH,P) ;get piece P from MSH array (passed by ref.) |
1680 | +"RTN","HLCSTCP1",145,0) |
1681 | + N FS,I,L,L1,L2,X,Y |
1682 | +"RTN","HLCSTCP1",146,0) |
1683 | + S FS=$E(MSH(1,0),4),(L2,Y)=0,X="" |
1684 | +"RTN","HLCSTCP1",147,0) |
1685 | + F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0)) |
1686 | +"RTN","HLCSTCP1",148,0) |
1687 | + . S:L1=1 L=L+1 |
1688 | +"RTN","HLCSTCP1",149,0) |
1689 | + . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y)) |
1690 | +"RTN","HLCSTCP1",150,0) |
1691 | + . S L2=Y,Y=L |
1692 | +"RTN","HLCSTCP1",151,0) |
1693 | + Q X |
1694 | +"RTN","HLCSTCP1",152,0) |
1695 | + ; |
1696 | +"RTN","HLCSTCP1",153,0) |
1697 | +PING ;process PING message |
1698 | +"RTN","HLCSTCP1",154,0) |
1699 | + S X=HLMSG(1,0) |
1700 | +"RTN","HLCSTCP1",155,0) |
1701 | + I X[HLDEND U IO W X,! |
1702 | +"RTN","HLCSTCP1",156,0) |
1703 | +CLEAN ;reset var. for next message |
1704 | +"RTN","HLCSTCP1",157,0) |
1705 | + K HLMSG |
1706 | +"RTN","HLCSTCP1",158,0) |
1707 | + S HLINE=0,HLRDOUT=1 |
1708 | +"RTN","HLCSTCP1",159,0) |
1709 | + Q |
1710 | +"RTN","HLCSTCP1",160,0) |
1711 | + ; |
1712 | +"RTN","HLCSTCP1",161,0) |
1713 | +ERROR ; Error trap for disconnect error and return back to the read loop. |
1714 | +"RTN","HLCSTCP1",162,0) |
1715 | + S $ETRAP="D UNWIND^%ZTER" |
1716 | +"RTN","HLCSTCP1",163,0) |
1717 | + I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q |
1718 | +"RTN","HLCSTCP1",164,0) |
1719 | + I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q |
1720 | +"RTN","HLCSTCP1",165,0) |
1721 | + S HLCSOUT=1 D ^%ZTER,CC("Error") |
1722 | +"RTN","HLCSTCP1",166,0) |
1723 | + D UNWIND^%ZTER |
1724 | +"RTN","HLCSTCP1",167,0) |
1725 | + Q |
1726 | +"RTN","HLCSTCP1",168,0) |
1727 | + ; |
1728 | +"RTN","HLCSTCP1",169,0) |
1729 | +CC(X) ;cleanup and close |
1730 | +"RTN","HLCSTCP1",170,0) |
1731 | + D MON^HLCSTCP(X) |
1732 | +"RTN","HLCSTCP1",171,0) |
1733 | + H 2 |
1734 | +"RTN","HLCSTCP1",172,0) |
1735 | + Q |
1736 | +"RTN","HLCSTCP1",173,0) |
1737 | +RESET ;reset info as a result of no end block |
1738 | +"RTN","HLCSTCP1",174,0) |
1739 | + N % |
1740 | +"RTN","HLCSTCP1",175,0) |
1741 | + S HLMSG(1,0)=HLMSG(HLINE,0) |
1742 | +"RTN","HLCSTCP1",176,0) |
1743 | + F %=2:1:HLINE K HLMSG(%,0) |
1744 | +"RTN","HLCSTCP1",177,0) |
1745 | + S HLINE=1 |
1746 | +"RTN","HLCSTCP1",178,0) |
1747 | + Q |
1748 | +"RTN","MSCZJOB") |
1749 | +0^1^B12797960 |
1750 | +"RTN","MSCZJOB",1,0) |
1751 | +MSCZJOB ;GFT/MSC;28JAN2009 |
1752 | +"RTN","MSCZJOB",2,0) |
1753 | + ;;8.0;KERNEL;**MSC** |
1754 | +"RTN","MSCZJOB",3,0) |
1755 | + W !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
1756 | +"RTN","MSCZJOB",4,0) |
1757 | + N MSC |
1758 | +"RTN","MSCZJOB",5,0) |
1759 | +DDS ; |
1760 | +"RTN","MSCZJOB",6,0) |
1761 | + S DDSFILE=3.081,DR="[MSCZJOBEXAM]",DDSPARM="S" |
1762 | +"RTN","MSCZJOB",7,0) |
1763 | + D ^DDS Q |
1764 | +"RTN","MSCZJOB",8,0) |
1765 | + ; |
1766 | +"RTN","MSCZJOB",9,0) |
1767 | +UNLOCK(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK |
1768 | +"RTN","MSCZJOB",10,0) |
1769 | + N X,R S R=$G(@MSC@(MSCJOBID,"L",D0)) I R'["^" Q ;CAN'T SEE IT |
1770 | +"RTN","MSCZJOB",11,0) |
1771 | + S R=$P(R,"~",2),R="^"_$S(R'["(":$P(R," "),1:$P(R,")")_")"),X="L "_R D ^DIM Q:'$D(X) ;GOOD SYNTAX? |
1772 | +"RTN","MSCZJOB",12,0) |
1773 | + D UNLOCK^MSCZJOBU(R,MSCJOBID) |
1774 | +"RTN","MSCZJOB",13,0) |
1775 | + Q |
1776 | +"RTN","MSCZJOB",14,0) |
1777 | + ; |
1778 | +"RTN","MSCZJOB",15,0) |
1779 | + ; |
1780 | +"RTN","MSCZJOB",16,0) |
1781 | +KILL(J) ;FROM FIELD |
1782 | +"RTN","MSCZJOB",17,0) |
1783 | + D KILL^MSCZJOBU(J) |
1784 | +"RTN","MSCZJOB",18,0) |
1785 | + Q |
1786 | +"RTN","MSCZJOB",19,0) |
1787 | + ; |
1788 | +"RTN","MSCZJOB",20,0) |
1789 | + ; |
1790 | +"RTN","MSCZJOB",21,0) |
1791 | + ; |
1792 | +"RTN","MSCZJOB",22,0) |
1793 | + ; |
1794 | +"RTN","MSCZJOB",23,0) |
1795 | +COMPMUL ;COMPUTED MULTIPLE FOR MSCZJOBEXAM BLOCK |
1796 | +"RTN","MSCZJOB",24,0) |
1797 | + N X,D0,J |
1798 | +"RTN","MSCZJOB",25,0) |
1799 | + S MSC="^TMP(""MSCZJOB"")" D POLL |
1800 | +"RTN","MSCZJOB",26,0) |
1801 | + F D0=0:0 S D0=$O(MSCZJOB(D0)) Q:'D0 D |
1802 | +"RTN","MSCZJOB",27,0) |
1803 | + .S MSCZJOB(D0)=MSCZJOB(D0)_U_$$DEV(D0)_U_$$USER(D0)_U_$$NSP(D0)_U_U_U_U_U_$$ROUTINE(D0) |
1804 | +"RTN","MSCZJOB",28,0) |
1805 | + .S X=MSCZJOB(D0) X DICMX |
1806 | +"RTN","MSCZJOB",29,0) |
1807 | + Q |
1808 | +"RTN","MSCZJOB",30,0) |
1809 | +JOB(D0) Q $P(MSCZJOB(D0),U) ;*** |
1810 | +"RTN","MSCZJOB",31,0) |
1811 | +DEV(D0) Q $$FIND(D0,"I","$PRINCIPAL") |
1812 | +"RTN","MSCZJOB",32,0) |
1813 | +NSP(D0) N N D Q N |
1814 | +"RTN","MSCZJOB",33,0) |
1815 | + .N L,P S N=$$FIND(D0,"I","$ZGBLDIR"),L=$L(N,"/") I L<2 Q |
1816 | +"RTN","MSCZJOB",34,0) |
1817 | + .F L=L-1:-1:2 S P=$P(N,"/",L) I P'[".",P'["globals" Q |
1818 | +"RTN","MSCZJOB",35,0) |
1819 | + .S P=1 I $P(N,"/")="" S P=2 |
1820 | +"RTN","MSCZJOB",36,0) |
1821 | + .S N=$P(N,"/",P,L) |
1822 | +"RTN","MSCZJOB",37,0) |
1823 | +USER(D0) Q $P($G(^VA(200,+$$FIND(D0,"V","DUZ"),0)),U) |
1824 | +"RTN","MSCZJOB",38,0) |
1825 | +ROUTINE(D0) Q $$FIND(D0,"V","%ZPOS") |
1826 | +"RTN","MSCZJOB",39,0) |
1827 | + ; |
1828 | +"RTN","MSCZJOB",40,0) |
1829 | +FIND(D0,ARR,KEY) N I,J,X S X="",J=+MSCZJOB(D0) |
1830 | +"RTN","MSCZJOB",41,0) |
1831 | + F I=0:0 S I=$O(@MSC@(J,ARR,I)) Q:'I I $P(^(I),KEY_"=")="" S X=$TR($P(^(I),"=",2),"""") Q |
1832 | +"RTN","MSCZJOB",42,0) |
1833 | + Q X |
1834 | +"RTN","MSCZJOB",43,0) |
1835 | + ; |
1836 | +"RTN","MSCZJOB",44,0) |
1837 | + ; |
1838 | +"RTN","MSCZJOB",45,0) |
1839 | + ; |
1840 | +"RTN","MSCZJOB",46,0) |
1841 | + ; |
1842 | +"RTN","MSCZJOB",47,0) |
1843 | + ; |
1844 | +"RTN","MSCZJOB",48,0) |
1845 | +COMPSTK ;COMPUTED MULTIPLE FOR MSCZJOBSTACK BLOCK |
1846 | +"RTN","MSCZJOB",49,0) |
1847 | + S MSC="^TMP(""MSCZJOB"")" K @MSC@(MSCJOBID) D POLL1 |
1848 | +"RTN","MSCZJOB",50,0) |
1849 | + N D0,J S J=MSCJOBID |
1850 | +"RTN","MSCZJOB",51,0) |
1851 | + F D0=1:1:$O(@MSC@(J,"S",""),-1) S X="" X DICMX |
1852 | +"RTN","MSCZJOB",52,0) |
1853 | + Q |
1854 | +"RTN","MSCZJOB",53,0) |
1855 | + ; |
1856 | +"RTN","MSCZJOB",54,0) |
1857 | +STACK(D0) N X S X=$G(@MSC@(MSCJOBID,"S",D0)) |
1858 | +"RTN","MSCZJOB",55,0) |
1859 | + Q X |
1860 | +"RTN","MSCZJOB",56,0) |
1861 | + ; |
1862 | +"RTN","MSCZJOB",57,0) |
1863 | + ; |
1864 | +"RTN","MSCZJOB",58,0) |
1865 | +COMPVARS ;COMPUTED MULTIPLE FOR MSCZJOBVARS BLOCK |
1866 | +"RTN","MSCZJOB",59,0) |
1867 | + S MSC="^TMP(""MSCZJOB"")" K @MSC@(MSCJOBID) D POLL1 |
1868 | +"RTN","MSCZJOB",60,0) |
1869 | + N D0,J S J=MSCJOBID |
1870 | +"RTN","MSCZJOB",61,0) |
1871 | + F D0=1:1:$O(@MSC@(J,"V",""),-1) S X="" X DICMX |
1872 | +"RTN","MSCZJOB",62,0) |
1873 | + Q |
1874 | +"RTN","MSCZJOB",63,0) |
1875 | + ; |
1876 | +"RTN","MSCZJOB",64,0) |
1877 | + ; |
1878 | +"RTN","MSCZJOB",65,0) |
1879 | +COMPLKS ;COMPUTED MULTIPLE FOR MSCZJOBLOCKS BLOCK |
1880 | +"RTN","MSCZJOB",66,0) |
1881 | + S MSC="^TMP(""MSCZJOB"")" D POLL1 |
1882 | +"RTN","MSCZJOB",67,0) |
1883 | + N D0 |
1884 | +"RTN","MSCZJOB",68,0) |
1885 | + F D0=1:1:$$LOCKS S X="" X DICMX |
1886 | +"RTN","MSCZJOB",69,0) |
1887 | + Q |
1888 | +"RTN","MSCZJOB",70,0) |
1889 | + ; |
1890 | +"RTN","MSCZJOB",71,0) |
1891 | +LOCKS() Q +$O(@MSC@(MSCJOBID,"L",""),-1) |
1892 | +"RTN","MSCZJOB",72,0) |
1893 | + ; |
1894 | +"RTN","MSCZJOB",73,0) |
1895 | + ; |
1896 | +"RTN","MSCZJOB",74,0) |
1897 | +POLL K MSCZJOB ;D HLP^DDSUTL(" POLLING JOBS.....") |
1898 | +"RTN","MSCZJOB",75,0) |
1899 | + I $G(^%ZOSF("OS"))["GT.M" D |
1900 | +"RTN","MSCZJOB",76,0) |
1901 | + .K @MSC |
1902 | +"RTN","MSCZJOB",77,0) |
1903 | + .D INTRPT^MSCZJOBU("*") ;SETS UP ^TMP |
1904 | +"RTN","MSCZJOB",78,0) |
1905 | + .N MSCA,I D PIDS^MSCZJOBU(.MSCA) |
1906 | +"RTN","MSCZJOB",79,0) |
1907 | + .S MSCA="" F I=1:1 S MSCA=$O(MSCA(MSCA)) Q:'MSCA S MSCZJOB(I)=MSCA ;SETS UP LOCAL ARRAY |
1908 | +"RTN","MSCZJOB",80,0) |
1909 | + .H 1 ;WAIT FOR POLLING |
1910 | +"RTN","MSCZJOB",81,0) |
1911 | + D TEST |
1912 | +"RTN","MSCZJOB",82,0) |
1913 | + Q |
1914 | +"RTN","MSCZJOB",83,0) |
1915 | + ; |
1916 | +"RTN","MSCZJOB",84,0) |
1917 | +POLL1 Q:'$G(MSCJOBID) |
1918 | +"RTN","MSCZJOB",85,0) |
1919 | + I $G(^%ZOSF("OS"))["GT.M" D |
1920 | +"RTN","MSCZJOB",86,0) |
1921 | + .K @MSC@(MSCJOBID) |
1922 | +"RTN","MSCZJOB",87,0) |
1923 | + .D INTRPT^MSCZJOBU(MSCJOBID) ;SETS UP ^TMP(MSCZJOB) |
1924 | +"RTN","MSCZJOB",88,0) |
1925 | + .H 1 ;WAIT FOR POLLING |
1926 | +"RTN","MSCZJOB",89,0) |
1927 | + D TEST |
1928 | +"RTN","MSCZJOB",90,0) |
1929 | + Q |
1930 | +"RTN","MSCZJOB",91,0) |
1931 | + ; |
1932 | +"RTN","MSCZJOB",92,0) |
1933 | + ; |
1934 | +"RTN","MSCZJOB",93,0) |
1935 | + ; |
1936 | +"RTN","MSCZJOB",94,0) |
1937 | + ; |
1938 | +"RTN","MSCZJOB",95,0) |
1939 | +TEST Q |
1940 | +"RTN","MSCZJOB",96,0) |
1941 | +COMPLK ;COMPUTED MULTIPLE FOR MSCZLOCK BLOCK |
1942 | +"RTN","MSCZJOB",97,0) |
1943 | + N X,D0,J |
1944 | +"RTN","MSCZJOB",98,0) |
1945 | + S MSC="^TMP(""MSCZJOB"")" D POLL S D0=0 |
1946 | +"RTN","MSCZJOB",99,0) |
1947 | + F K=0:0 S K=$O(MSCZJOB(K)) Q:'K D |
1948 | +"RTN","MSCZJOB",100,0) |
1949 | + .F J=0:0 S J=$O(^TMP("MSCZJOB",MSCZJOB(K),"L",J)) Q:'J S A=$TR(^(J),U,"~") D |
1950 | +"RTN","MSCZJOB",101,0) |
1951 | + ..S D0=D0+1,MSCZLK(D0)=$P(A,"LOCK ",2,9)_U_$$USER(K)_U_$TR($$ROUTINE(K),U,"~")_"^^"_MSCZJOB(K) |
1952 | +"RTN","MSCZJOB",102,0) |
1953 | + ..S X=MSCZLK(D0) X DICMX |
1954 | +"RTN","MSCZJOB",103,0) |
1955 | + Q |
1956 | +"RTN","MSCZJOB",104,0) |
1957 | +LOCK ; ; |
1958 | +"RTN","MSCZJOB",105,0) |
1959 | + S DDSFILE=3.081,DR="[MSCZLOCK]",DDSPARM="S" |
1960 | +"RTN","MSCZJOB",106,0) |
1961 | + D ^DDS Q |
1962 | +"RTN","MSCZJOB",107,0) |
1963 | +UNL(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK |
1964 | +"RTN","MSCZJOB",108,0) |
1965 | + N X,R S R=$P($G(MSCZLK(D0)),U),P=$P($G(MSCZLK(D0)),U,5) ;I R'["^" Q ;CAN'T SEE IT |
1966 | +"RTN","MSCZJOB",109,0) |
1967 | + S R=$P(R,"~",2),R="^"_$S(R'["(":$P(R," "),1:$P(R,")")_")"),X="L "_R D ^DIM Q:'$D(X) ;GOOD SYNTAX? |
1968 | +"RTN","MSCZJOB",110,0) |
1969 | + D UNLOCK^MSCZJOBU(R,P) |
1970 | +"RTN","MSCZJOBU") |
1971 | +0^4^B3546679 |
1972 | +"RTN","MSCZJOBU",1,0) |
1973 | +MSCZJOBU ;RHL/MSC;26JUNE2007 |
1974 | +"RTN","MSCZJOBU",2,0) |
1975 | + ;;8.0;KERNEL;**MSC** |
1976 | +"RTN","MSCZJOBU",3,0) |
1977 | + ; |
1978 | +"RTN","MSCZJOBU",4,0) |
1979 | + ; JOB EXAM UTILITIES FOR GT.M |
1980 | +"RTN","MSCZJOBU",5,0) |
1981 | + Q |
1982 | +"RTN","MSCZJOBU",6,0) |
1983 | +PIDS(XARY) ; GET ARRAY OF ALL MUMPS PROCESS |
1984 | +"RTN","MSCZJOBU",7,0) |
1985 | + ; XARY PASSED BY REFERENCE |
1986 | +"RTN","MSCZJOBU",8,0) |
1987 | + ; RETURNS XARY(PID)="" |
1988 | +"RTN","MSCZJOBU",9,0) |
1989 | + ; NOTE: Unix PID=$J for all mumps processes. |
1990 | +"RTN","MSCZJOBU",10,0) |
1991 | + ; |
1992 | +"RTN","MSCZJOBU",11,0) |
1993 | + N %FILE |
1994 | +"RTN","MSCZJOBU",12,0) |
1995 | + S %FILE="/tmp/msczjob"_$J_".tmp" |
1996 | +"RTN","MSCZJOBU",13,0) |
1997 | + ZSYSTEM "ps --no-headers -o pid= -C mumps>"_%FILE |
1998 | +"RTN","MSCZJOBU",14,0) |
1999 | + O %FILE::0 Q:'$T |
2000 | +"RTN","MSCZJOBU",15,0) |
2001 | + ; |
2002 | +"RTN","MSCZJOBU",16,0) |
2003 | + N %I S %I=$I |
2004 | +"RTN","MSCZJOBU",17,0) |
2005 | + N %J ; $JOB |
2006 | +"RTN","MSCZJOBU",18,0) |
2007 | + N %LINE |
2008 | +"RTN","MSCZJOBU",19,0) |
2009 | + N U S U="^" |
2010 | +"RTN","MSCZJOBU",20,0) |
2011 | + F U %FILE R %LINE U %I Q:%LINE="" D |
2012 | +"RTN","MSCZJOBU",21,0) |
2013 | + . Q:$P(%LINE,U)="PID" ; header line |
2014 | +"RTN","MSCZJOBU",22,0) |
2015 | + . S %J=$P(%LINE,U) |
2016 | +"RTN","MSCZJOBU",23,0) |
2017 | + . F Q:$E(%J,1)'=" " S %J=$E(%J,2,999) |
2018 | +"RTN","MSCZJOBU",24,0) |
2019 | + . S XARY(%J)="" |
2020 | +"RTN","MSCZJOBU",25,0) |
2021 | + ; |
2022 | +"RTN","MSCZJOBU",26,0) |
2023 | + C %FILE:DELETE |
2024 | +"RTN","MSCZJOBU",27,0) |
2025 | + ;ZSYSTEM "rm "_$P(%FILE,".",1)_"*" |
2026 | +"RTN","MSCZJOBU",28,0) |
2027 | + Q |
2028 | +"RTN","MSCZJOBU",29,0) |
2029 | + ; |
2030 | +"RTN","MSCZJOBU",30,0) |
2031 | + ; |
2032 | +"RTN","MSCZJOBU",31,0) |
2033 | +INTRPT(PID) ; SEND mupip intrpt to each process. |
2034 | +"RTN","MSCZJOBU",32,0) |
2035 | + ; WHICH CAUSES THE $ZINTERRUPT CODE TO BE EXECUTED. |
2036 | +"RTN","MSCZJOBU",33,0) |
2037 | + ; PID PASSED BY VALUE |
2038 | +"RTN","MSCZJOBU",34,0) |
2039 | + ; PID CAN BE A SINGLE PID, I.E. $J |
2040 | +"RTN","MSCZJOBU",35,0) |
2041 | + ; PID CAN BE A "*" WHICH SENDS AN INTERRUPT TO ALL MUMPS PROCESSES |
2042 | +"RTN","MSCZJOBU",36,0) |
2043 | + ; |
2044 | +"RTN","MSCZJOBU",37,0) |
2045 | + Q:$G(PID)="" |
2046 | +"RTN","MSCZJOBU",38,0) |
2047 | + ; |
2048 | +"RTN","MSCZJOBU",39,0) |
2049 | + I PID="*" D Q ; ALL PIDS |
2050 | +"RTN","MSCZJOBU",40,0) |
2051 | + . N ARRAY |
2052 | +"RTN","MSCZJOBU",41,0) |
2053 | + . D PIDS(.ARRAY) |
2054 | +"RTN","MSCZJOBU",42,0) |
2055 | + . N %J S %J="" |
2056 | +"RTN","MSCZJOBU",43,0) |
2057 | + . F S %J=$O(ARRAY(%J)) Q:%J="" D |
2058 | +"RTN","MSCZJOBU",44,0) |
2059 | + . . S A="test1",c="mupip intrpt "_%J_" > /dev/null" |
2060 | +"RTN","MSCZJOBU",45,0) |
2061 | + . . OPEN A:(COMM="mupip intrpt "_%J)::"PIPE" U A C A |
2062 | +"RTN","MSCZJOBU",46,0) |
2063 | + . . ;ZSYSTEM "mupip intrpt "_%J_" > /dev/null" |
2064 | +"RTN","MSCZJOBU",47,0) |
2065 | + ; |
2066 | +"RTN","MSCZJOBU",48,0) |
2067 | + ; JUST 1 PID |
2068 | +"RTN","MSCZJOBU",49,0) |
2069 | + Q:PID'?1N.N |
2070 | +"RTN","MSCZJOBU",50,0) |
2071 | + S A="test1" |
2072 | +"RTN","MSCZJOBU",51,0) |
2073 | + OPEN A:(COMM="mupip intrpt "_PID)::"PIPE" U A C A |
2074 | +"RTN","MSCZJOBU",52,0) |
2075 | + ;ZSYSTEM "mupip intrpt "_PID_" > /dev/null" |
2076 | +"RTN","MSCZJOBU",53,0) |
2077 | + Q |
2078 | +"RTN","MSCZJOBU",54,0) |
2079 | + ; |
2080 | +"RTN","MSCZJOBU",55,0) |
2081 | +KILL(PID) ; Send PID to mupip to kill process |
2082 | +"RTN","MSCZJOBU",56,0) |
2083 | + Q:PID'?1N.N |
2084 | +"RTN","MSCZJOBU",57,0) |
2085 | + X "ZSYSTEM ""mupip stop ""_PID_"" > /dev/null""" |
2086 | +"RTN","MSCZJOBU",58,0) |
2087 | + Q |
2088 | +"RTN","MSCZJOBU",59,0) |
2089 | + ; |
2090 | +"RTN","MSCZJOBU",60,0) |
2091 | +UNLOCK(NODE,PROC) ; Use lke to remove lock on NODE. |
2092 | +"RTN","MSCZJOBU",61,0) |
2093 | + N X |
2094 | +"RTN","MSCZJOBU",62,0) |
2095 | + S X="lke clear -lock="""_NODE_""" -nointeractive -output=/dev/null" |
2096 | +"RTN","MSCZJOBU",63,0) |
2097 | + ZSYSTEM X |
2098 | +"RTN","MSCZJOBU",64,0) |
2099 | + Q |
2100 | +"RTN","XOBVLL") |
2101 | +0^19^B18038185 |
2102 | +"RTN","XOBVLL",1,0) |
2103 | +XOBVLL ;; mjk/alb MSC/JDA - VistALink Listen and Spawn Code ; 07/27/2002 13:00 |
2104 | +"RTN","XOBVLL",2,0) |
2105 | + ;;1.5;VistALink;**MSC**;Sep 09, 2005 |
2106 | +"RTN","XOBVLL",3,0) |
2107 | + ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026] |
2108 | +"RTN","XOBVLL",4,0) |
2109 | + ; |
2110 | +"RTN","XOBVLL",5,0) |
2111 | + QUIT |
2112 | +"RTN","XOBVLL",6,0) |
2113 | + ; |
2114 | +"RTN","XOBVLL",7,0) |
2115 | + ; ***deprecated*** tag ; Use START^XOBVTCP instead |
2116 | +"RTN","XOBVLL",8,0) |
2117 | +START(SOCKET) ; -- start listener |
2118 | +"RTN","XOBVLL",9,0) |
2119 | + DO START^XOBVTCP(SOCKET) |
2120 | +"RTN","XOBVLL",10,0) |
2121 | + QUIT |
2122 | +"RTN","XOBVLL",11,0) |
2123 | + ; |
2124 | +"RTN","XOBVLL",12,0) |
2125 | + ; ***deprecated*** tag ; Use UCX^XOBVTCP instead |
2126 | +"RTN","XOBVLL",13,0) |
2127 | +UCX ; -- VMS TCPIP (UCX) multi-thread entry point |
2128 | +"RTN","XOBVLL",14,0) |
2129 | + ; -- Called from VistALink .com files |
2130 | +"RTN","XOBVLL",15,0) |
2131 | + GOTO UCX^XOBVTCP |
2132 | +"RTN","XOBVLL",16,0) |
2133 | + ; |
2134 | +"RTN","XOBVLL",17,0) |
2135 | +SPAWN ; -- spawned process |
2136 | +"RTN","XOBVLL",18,0) |
2137 | + NEW X,XOBSTOP,XOBPORT,XOBHDLR,XOBLASTR |
2138 | +"RTN","XOBVLL",19,0) |
2139 | + ; |
2140 | +"RTN","XOBVLL",20,0) |
2141 | + SET XOBSTOP=0 |
2142 | +"RTN","XOBVLL",21,0) |
2143 | + SET XOBPORT=IO |
2144 | +"RTN","XOBVLL",22,0) |
2145 | + SET U="^" |
2146 | +"RTN","XOBVLL",23,0) |
2147 | + ; |
2148 | +"RTN","XOBVLL",24,0) |
2149 | + ; -- initialize timestamp for last time request made (used for debugging) |
2150 | +"RTN","XOBVLL",25,0) |
2151 | + SET XOBLASTR=0 |
2152 | +"RTN","XOBVLL",26,0) |
2153 | + ; |
2154 | +"RTN","XOBVLL",27,0) |
2155 | + ; -- set error trap |
2156 | +"RTN","XOBVLL",28,0) |
2157 | + ;Set up the error trap |
2158 | +"RTN","XOBVLL",29,0) |
2159 | + SET $ETRAP="DO ^%ZTER HALT" |
2160 | +"RTN","XOBVLL",30,0) |
2161 | + ; |
2162 | +"RTN","XOBVLL",31,0) |
2163 | + ; -- attempt to share the license; must have TCP port open first |
2164 | +"RTN","XOBVLL",32,0) |
2165 | + USE XOBPORT IF $TEXT(SHARELIC^%ZOSV)'="" DO SHARELIC^%ZOSV(1) |
2166 | +"RTN","XOBVLL",33,0) |
2167 | + ; |
2168 | +"RTN","XOBVLL",34,0) |
2169 | + ; -- start RUM for VistALink Handler |
2170 | +"RTN","XOBVLL",35,0) |
2171 | + DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1) |
2172 | +"RTN","XOBVLL",36,0) |
2173 | + ; |
2174 | +"RTN","XOBVLL",37,0) |
2175 | + SET:^%ZOSF("OS")["GT.M" X=$$GTM^XOBVRH(.XOBHDLR) |
2176 | +"RTN","XOBVLL",38,0) |
2177 | + ; -- cache/initialize startup request handlers |
2178 | +"RTN","XOBVLL",39,0) |
2179 | + SET:^%ZOSF("OS")["OpenM" X=$$CACHE^XOBVRH(.XOBHDLR) |
2180 | +"RTN","XOBVLL",40,0) |
2181 | + IF 'X DO RMERR^XOBVRM(184001,$PIECE(X,U,2)) QUIT |
2182 | +"RTN","XOBVLL",41,0) |
2183 | + ; |
2184 | +"RTN","XOBVLL",42,0) |
2185 | + ; -- initialize tcp processing variables |
2186 | +"RTN","XOBVLL",43,0) |
2187 | + DO INIT^XOBVSKT |
2188 | +"RTN","XOBVLL",44,0) |
2189 | + ; |
2190 | +"RTN","XOBVLL",45,0) |
2191 | + ; -- change job name if possible |
2192 | +"RTN","XOBVLL",46,0) |
2193 | + DO SETNM^%ZOSV("VLink_"_$$CNV^XLFUTL($J,16)) |
2194 | +"RTN","XOBVLL",47,0) |
2195 | + ; |
2196 | +"RTN","XOBVLL",48,0) |
2197 | + ; -- loop until told to stop |
2198 | +"RTN","XOBVLL",49,0) |
2199 | + FOR DO NXTCALL QUIT:XOBSTOP |
2200 | +"RTN","XOBVLL",50,0) |
2201 | + ; |
2202 | +"RTN","XOBVLL",51,0) |
2203 | + ; -- final/clean tcp processing variables |
2204 | +"RTN","XOBVLL",52,0) |
2205 | + DO FINAL^XOBVSKT |
2206 | +"RTN","XOBVLL",53,0) |
2207 | + ; |
2208 | +"RTN","XOBVLL",54,0) |
2209 | + ; -- stop RUM for VistALink Handler |
2210 | +"RTN","XOBVLL",55,0) |
2211 | + DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,2) |
2212 | +"RTN","XOBVLL",56,0) |
2213 | + ; |
2214 | +"RTN","XOBVLL",57,0) |
2215 | + QUIT |
2216 | +"RTN","XOBVLL",58,0) |
2217 | + ; |
2218 | +"RTN","XOBVLL",59,0) |
2219 | +NXTCALL ; -- do next call |
2220 | +"RTN","XOBVLL",60,0) |
2221 | + NEW X,XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBOK,XOBRL,XOBDATA |
2222 | +"RTN","XOBVLL",61,0) |
2223 | + ; |
2224 | +"RTN","XOBVLL",62,0) |
2225 | + ; -- set up error trap |
2226 | +"RTN","XOBVLL",63,0) |
2227 | + NEW $ESTACK SET $ETRAP="DO SYSERR^XOBVLL" |
2228 | +"RTN","XOBVLL",64,0) |
2229 | + ; |
2230 | +"RTN","XOBVLL",65,0) |
2231 | + ; -- setup environment variables |
2232 | +"RTN","XOBVLL",66,0) |
2233 | + NEW DIQUIET SET DIQUIET=1 |
2234 | +"RTN","XOBVLL",67,0) |
2235 | + SET U="^",DTIME=$GET(DTIME,900),DT=$$DT^XLFDT() |
2236 | +"RTN","XOBVLL",68,0) |
2237 | + ; |
2238 | +"RTN","XOBVLL",69,0) |
2239 | + ; -- initialize 'current' request handler to empty string |
2240 | +"RTN","XOBVLL",70,0) |
2241 | + SET XOBHDLR="" |
2242 | +"RTN","XOBVLL",71,0) |
2243 | + ; |
2244 | +"RTN","XOBVLL",72,0) |
2245 | + ; -- # of chars to get on first read / read 11 for Broker initial read |
2246 | +"RTN","XOBVLL",73,0) |
2247 | + SET XOBREAD=11 |
2248 | +"RTN","XOBVLL",74,0) |
2249 | + ; |
2250 | +"RTN","XOBVLL",75,0) |
2251 | + ; -- get J2SE heartbet rate for timeout plus network latency factor |
2252 | +"RTN","XOBVLL",76,0) |
2253 | + SET XOBTO=$$GETRATE^XOBVLIB()+$$GETDELTA^XOBVLIB() |
2254 | +"RTN","XOBVLL",77,0) |
2255 | + ; |
2256 | +"RTN","XOBVLL",78,0) |
2257 | + ; -- get J2EE timeout value for app serv environment |
2258 | +"RTN","XOBVLL",79,0) |
2259 | + IF $GET(XOBSYS("ENV"))="j2ee" SET XOBTO=$$GETASTO^XOBVLIB() |
2260 | +"RTN","XOBVLL",80,0) |
2261 | + ; |
2262 | +"RTN","XOBVLL",81,0) |
2263 | + ; -- set first read flag |
2264 | +"RTN","XOBVLL",82,0) |
2265 | + SET XOBFIRST=1 |
2266 | +"RTN","XOBVLL",83,0) |
2267 | + ; |
2268 | +"RTN","XOBVLL",84,0) |
2269 | + ; -- setup intake global |
2270 | +"RTN","XOBVLL",85,0) |
2271 | + SET XOBROOT=$NAME(^TMP("XOBVLL",$JOB)) |
2272 | +"RTN","XOBVLL",86,0) |
2273 | + KILL @XOBROOT |
2274 | +"RTN","XOBVLL",87,0) |
2275 | + ; |
2276 | +"RTN","XOBVLL",88,0) |
2277 | + ; -- read from socket port |
2278 | +"RTN","XOBVLL",89,0) |
2279 | + USE XOBPORT |
2280 | +"RTN","XOBVLL",90,0) |
2281 | + SET XOBOK=$$READ^XOBVSKT(XOBROOT,.XOBREAD,.XOBTO,.XOBFIRST,.XOBSTOP,.XOBDATA,.XOBHDLR) |
2282 | +"RTN","XOBVLL",91,0) |
2283 | + ; |
2284 | +"RTN","XOBVLL",92,0) |
2285 | + ; -- timed out ; cleanup user and exit |
2286 | +"RTN","XOBVLL",93,0) |
2287 | + IF 'XOBOK!(XOBSTOP) DO GOTO NXTCALLQ |
2288 | +"RTN","XOBVLL",94,0) |
2289 | + . IF $GET(DUZ) DO CLEAN^XOBSCAV1 |
2290 | +"RTN","XOBVLL",95,0) |
2291 | + . SET XOBSTOP=1 |
2292 | +"RTN","XOBVLL",96,0) |
2293 | + ; |
2294 | +"RTN","XOBVLL",97,0) |
2295 | + ; -- need null device |
2296 | +"RTN","XOBVLL",98,0) |
2297 | + IF '$DATA(XOBNULL) DO ERROR(181002,$$EZBLD^DIALOG(181002),XOBPORT) SET XOBSTOP=1 GOTO NXTCALLQ |
2298 | +"RTN","XOBVLL",99,0) |
2299 | + ; |
2300 | +"RTN","XOBVLL",100,0) |
2301 | + ; -- call request manager |
2302 | +"RTN","XOBVLL",101,0) |
2303 | + SET XOBOK=$$EN^XOBVRM(XOBROOT,.XOBDATA,.XOBHDLR) |
2304 | +"RTN","XOBVLL",102,0) |
2305 | + ; -- timestamp last time request made |
2306 | +"RTN","XOBVLL",103,0) |
2307 | + SET XOBLASTR=$$NOW^XLFDT() |
2308 | +"RTN","XOBVLL",104,0) |
2309 | + ; -- cleanup intake global |
2310 | +"RTN","XOBVLL",105,0) |
2311 | + KILL @XOBROOT |
2312 | +"RTN","XOBVLL",106,0) |
2313 | + ; |
2314 | +"RTN","XOBVLL",107,0) |
2315 | +NXTCALLQ ; -- exit |
2316 | +"RTN","XOBVLL",108,0) |
2317 | + QUIT |
2318 | +"RTN","XOBVLL",109,0) |
2319 | + ; |
2320 | +"RTN","XOBVLL",110,0) |
2321 | + ; ---------------------------------------------------------------------------------- |
2322 | +"RTN","XOBVLL",111,0) |
2323 | + ; System Error Handler |
2324 | +"RTN","XOBVLL",112,0) |
2325 | + ; ---------------------------------------------------------------------------------- |
2326 | +"RTN","XOBVLL",113,0) |
2327 | +SYSERR ; -- send system error message |
2328 | +"RTN","XOBVLL",114,0) |
2329 | + ; -- If we get an error in the error handler just Halt |
2330 | +"RTN","XOBVLL",115,0) |
2331 | + SET $ETRAP="D ^%ZTER HALT" |
2332 | +"RTN","XOBVLL",116,0) |
2333 | + ; |
2334 | +"RTN","XOBVLL",117,0) |
2335 | + DO ERROR(181001,$$EZBLD^DIALOG(181001,$$EC^%ZOSV),XOBPORT) ; -- Get the error code |
2336 | +"RTN","XOBVLL",118,0) |
2337 | + QUIT |
2338 | +"RTN","XOBVLL",119,0) |
2339 | + ; |
2340 | +"RTN","XOBVLL",120,0) |
2341 | +ERROR(XOBEC,XOBMSG,XOBPORT) ; -- send error message |
2342 | +"RTN","XOBVLL",121,0) |
2343 | + NEW XOBDAT |
2344 | +"RTN","XOBVLL",122,0) |
2345 | + ; |
2346 | +"RTN","XOBVLL",123,0) |
2347 | + ; -- If we get an error in the error handler just Halt |
2348 | +"RTN","XOBVLL",124,0) |
2349 | + SET $ETRAP="D ^%ZTER HALT" |
2350 | +"RTN","XOBVLL",125,0) |
2351 | + ; |
2352 | +"RTN","XOBVLL",126,0) |
2353 | + ; -- set up error info |
2354 | +"RTN","XOBVLL",127,0) |
2355 | + SET XOBDAT("MESSAGE TYPE")=3 |
2356 | +"RTN","XOBVLL",128,0) |
2357 | + SET XOBDAT("ERRORS",1,"CODE")=XOBEC |
2358 | +"RTN","XOBVLL",129,0) |
2359 | + SET XOBDAT("ERRORS",1,"ERROR TYPE")="system" |
2360 | +"RTN","XOBVLL",130,0) |
2361 | + SET XOBDAT("ERRORS",1,"FAULT STRING")="System Error" |
2362 | +"RTN","XOBVLL",131,0) |
2363 | + SET XOBDAT("ERRORS",1,"CDATA")=1 |
2364 | +"RTN","XOBVLL",132,0) |
2365 | + SET XOBDAT("ERRORS",1,"MESSAGE",1)=XOBMSG |
2366 | +"RTN","XOBVLL",133,0) |
2367 | + ; |
2368 | +"RTN","XOBVLL",134,0) |
2369 | + ; -- if serious error, save error info, logout, and halt |
2370 | +"RTN","XOBVLL",135,0) |
2371 | + IF XOBMSG["<READ>"!(XOBMSG["<WRITE>")!(XOBMSG["<SYSTEM>")!(XOBMSG["READERR")!(XOBMSG["WRITERR")!(XOBMSG["SYSERR") DO HALT |
2372 | +"RTN","XOBVLL",136,0) |
2373 | + . DO ^%ZTER |
2374 | +"RTN","XOBVLL",137,0) |
2375 | + . IF $GET(DUZ) DO CLEAN^XOBSCAV1 |
2376 | +"RTN","XOBVLL",138,0) |
2377 | + ; |
2378 | +"RTN","XOBVLL",139,0) |
2379 | + ; -- send error back to client |
2380 | +"RTN","XOBVLL",140,0) |
2381 | + USE XOBPORT |
2382 | +"RTN","XOBVLL",141,0) |
2383 | + DO ERROR^XOBVLIB(.XOBDAT) |
2384 | +"RTN","XOBVLL",142,0) |
2385 | + ; |
2386 | +"RTN","XOBVLL",143,0) |
2387 | + ; -- just quit if no slots are available or logins are disabled |
2388 | +"RTN","XOBVLL",144,0) |
2389 | + IF (XOBEC=181003)!(XOBEC=181004) QUIT |
2390 | +"RTN","XOBVLL",145,0) |
2391 | + ; |
2392 | +"RTN","XOBVLL",146,0) |
2393 | + ; -- need to make sure any locks are released since code aborted ungracefully |
2394 | +"RTN","XOBVLL",147,0) |
2395 | + LOCK |
2396 | +"RTN","XOBVLL",148,0) |
2397 | + ; |
2398 | +"RTN","XOBVLL",149,0) |
2399 | + ; -- Save off the error |
2400 | +"RTN","XOBVLL",150,0) |
2401 | + DO ^%ZTER |
2402 | +"RTN","XOBVLL",151,0) |
2403 | + ; |
2404 | +"RTN","XOBVLL",152,0) |
2405 | + ; -- go back to listening |
2406 | +"RTN","XOBVLL",153,0) |
2407 | + SET $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" DO KILL^XOBVLL G NXTCALLQ^XOBVLL",$ECODE=",U99," |
2408 | +"RTN","XOBVLL",154,0) |
2409 | + QUIT |
2410 | +"RTN","XOBVLL",155,0) |
2411 | + ; |
2412 | +"RTN","XOBVLL",156,0) |
2413 | +KILL ; -- new VistALink variables and then do big KILL |
2414 | +"RTN","XOBVLL",157,0) |
2415 | + NEW XOBPORT,XOBSTOP,XOBNULL,XOBOS,XOBSYS,XOBHDLR,XOBOK |
2416 | +"RTN","XOBVLL",158,0) |
2417 | + DO KILL^XUSCLEAN |
2418 | +"RTN","XOBVLL",159,0) |
2419 | + QUIT |
2420 | +"RTN","XOBVLL",160,0) |
2421 | + ; |
2422 | +"RTN","XOBVRH") |
2423 | +0^20^B13028891 |
2424 | +"RTN","XOBVRH",1,0) |
2425 | +XOBVRH ;mjk/alb SC/JDA - VistaLink Request Handler Utilities ; 07/27/2002 13:00 |
2426 | +"RTN","XOBVRH",2,0) |
2427 | + ;;1.5;VistALink;**MSC**;Sep 09, 2005 |
2428 | +"RTN","XOBVRH",3,0) |
2429 | + ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026] |
2430 | +"RTN","XOBVRH",4,0) |
2431 | + ; |
2432 | +"RTN","XOBVRH",5,0) |
2433 | + QUIT |
2434 | +"RTN","XOBVRH",6,0) |
2435 | + ; |
2436 | +"RTN","XOBVRH",7,0) |
2437 | + ; ------------------------------------------------------------------ |
2438 | +"RTN","XOBVRH",8,0) |
2439 | + ; Message Type Handler Utilities |
2440 | +"RTN","XOBVRH",9,0) |
2441 | + ; ------------------------------------------------------------------ |
2442 | +"RTN","XOBVRH",10,0) |
2443 | + ; |
2444 | +"RTN","XOBVRH",11,0) |
2445 | + ; -- set up msg type info using message name |
2446 | +"RTN","XOBVRH",12,0) |
2447 | +MSGNAME(XOBMSG,XOBHDLR) ; -- set up msg type info |
2448 | +"RTN","XOBVRH",13,0) |
2449 | + QUIT $$SETMSG(XOBMSG,"NAME",.XOBHDLR) |
2450 | +"RTN","XOBVRH",14,0) |
2451 | + ; |
2452 | +"RTN","XOBVRH",15,0) |
2453 | + ; -- set up msg type info using message type |
2454 | +"RTN","XOBVRH",16,0) |
2455 | +MSGTYPE(XOBMSG,XOBHDLR) ; -- set up msg type info |
2456 | +"RTN","XOBVRH",17,0) |
2457 | + QUIT $$SETMSG(XOBMSG,"MSGTYPE",.XOBHDLR) |
2458 | +"RTN","XOBVRH",18,0) |
2459 | + ; |
2460 | +"RTN","XOBVRH",19,0) |
2461 | + ; -- set up msg type info using proprietary string |
2462 | +"RTN","XOBVRH",20,0) |
2463 | +MSGSINK(XOBMSG,XOBHDLR) ; -- set up msg type info |
2464 | +"RTN","XOBVRH",21,0) |
2465 | + QUIT $$SETMSG(XOBMSG,"D",.XOBHDLR) |
2466 | +"RTN","XOBVRH",22,0) |
2467 | + ; |
2468 | +"RTN","XOBVRH",23,0) |
2469 | +CACHE(XOBHDLR) ; -- cache req handlers |
2470 | +"RTN","XOBVRH",24,0) |
2471 | + NEW TYPE,TYPE0,XOBOK |
2472 | +"RTN","XOBVRH",25,0) |
2473 | + SET TYPE=0 |
2474 | +"RTN","XOBVRH",26,0) |
2475 | + SET XOBOK=1 |
2476 | +"RTN","XOBVRH",27,0) |
2477 | + ; |
2478 | +"RTN","XOBVRH",28,0) |
2479 | + ; -- load request handler info |
2480 | +"RTN","XOBVRH",29,0) |
2481 | + FOR SET TYPE=$ORDER(^XOB(18.05,"AS",1,TYPE)) QUIT:'TYPE DO QUIT:'XOBOK |
2482 | +"RTN","XOBVRH",30,0) |
2483 | + . SET TYPE0=$GET(^XOB(18.05,TYPE,0)) |
2484 | +"RTN","XOBVRH",31,0) |
2485 | + . DO SET(TYPE,TYPE0,.XOBHDLR) |
2486 | +"RTN","XOBVRH",32,0) |
2487 | + . SET XOBOK=$GET(XOBHDLR(TYPE)) |
2488 | +"RTN","XOBVRH",33,0) |
2489 | + . IF 'XOBOK SET XOBOK=XOBOK_U_$GET(XOBHDLR,"ERROR") |
2490 | +"RTN","XOBVRH",34,0) |
2491 | + QUIT XOBOK |
2492 | +"RTN","XOBVRH",35,0) |
2493 | + ; |
2494 | +"RTN","XOBVRH",36,0) |
2495 | + ; |
2496 | +"RTN","XOBVRH",37,0) |
2497 | +GTM(XOBHDLR) ; -- GT.M req handlers |
2498 | +"RTN","XOBVRH",38,0) |
2499 | + Q $$CACHE(.XOBHDLR) ; Same as Cache until something different is needed |
2500 | +"RTN","XOBVRH",39,0) |
2501 | + ; |
2502 | +"RTN","XOBVRH",40,0) |
2503 | + ; -- set up msg type info |
2504 | +"RTN","XOBVRH",41,0) |
2505 | +SETMSG(XOBMSG,XOBXREF,XOBHDLR) ; |
2506 | +"RTN","XOBVRH",42,0) |
2507 | + NEW TYPE,TYPEO |
2508 | +"RTN","XOBVRH",43,0) |
2509 | + KILL XOBHDLR(0) |
2510 | +"RTN","XOBVRH",44,0) |
2511 | + ; |
2512 | +"RTN","XOBVRH",45,0) |
2513 | + ; -- already cached? |
2514 | +"RTN","XOBVRH",46,0) |
2515 | + SET TYPE=$ORDER(XOBHDLR(XOBXREF,XOBMSG,"")) |
2516 | +"RTN","XOBVRH",47,0) |
2517 | + IF TYPE QUIT TYPE |
2518 | +"RTN","XOBVRH",48,0) |
2519 | + ; |
2520 | +"RTN","XOBVRH",49,0) |
2521 | + ; -- load req handler |
2522 | +"RTN","XOBVRH",50,0) |
2523 | + SET TYPE=+$ORDER(^XOB(18.05,XOBXREF,XOBMSG,"")) |
2524 | +"RTN","XOBVRH",51,0) |
2525 | + IF TYPE DO |
2526 | +"RTN","XOBVRH",52,0) |
2527 | + . SET TYPE0=$GET(^XOB(18.05,TYPE,0)) |
2528 | +"RTN","XOBVRH",53,0) |
2529 | + . DO SET(.TYPE,.TYPE0,.XOBHDLR) |
2530 | +"RTN","XOBVRH",54,0) |
2531 | + IF 'TYPE DO |
2532 | +"RTN","XOBVRH",55,0) |
2533 | + . SET XOBHDLR(0)=0 |
2534 | +"RTN","XOBVRH",56,0) |
2535 | + . SET XOBHDLR(0,"ERROR")="No message type defined" |
2536 | +"RTN","XOBVRH",57,0) |
2537 | + QUIT TYPE |
2538 | +"RTN","XOBVRH",58,0) |
2539 | + ; |
2540 | +"RTN","XOBVRH",59,0) |
2541 | +SET(TYPE,TYPE0,XOBHDLR) ; -- set nodes |
2542 | +"RTN","XOBVRH",60,0) |
2543 | + NEW IRTN,XOBICBK |
2544 | +"RTN","XOBVRH",61,0) |
2545 | + KILL XOBHDLR(TYPE) |
2546 | +"RTN","XOBVRH",62,0) |
2547 | + SET IRTN=$$IRTN(TYPE0) |
2548 | +"RTN","XOBVRH",63,0) |
2549 | + IF IRTN="" DO GOTO SETQ |
2550 | +"RTN","XOBVRH",64,0) |
2551 | + . SET XOBHDLR(TYPE)=0 |
2552 | +"RTN","XOBVRH",65,0) |
2553 | + . IF TYPE0="" SET XOBHDLR(TYPE,"ERROR")="No entry for message type ["_TYPE_"]" QUIT |
2554 | +"RTN","XOBVRH",66,0) |
2555 | + . IF IRTN="" SET XOBHDLR(TYPE,"ERROR")="Invalid interface routine specified ["_$PIECE(TYPE0,U,5)_"]" QUIT |
2556 | +"RTN","XOBVRH",67,0) |
2557 | + ; |
2558 | +"RTN","XOBVRH",68,0) |
2559 | + SET XOBHDLR(TYPE)=1 |
2560 | +"RTN","XOBVRH",69,0) |
2561 | + SET XOBHDLR(TYPE,"AUTHENTICATE")=+$PIECE(TYPE0,U,4) |
2562 | +"RTN","XOBVRH",70,0) |
2563 | + SET XOBHDLR(TYPE,"REQHDLR")="DO REQHDLR^"_IRTN_"(.XOBDATA)" |
2564 | +"RTN","XOBVRH",71,0) |
2565 | + SET XOBHDLR(TYPE,"READER")="DO READER^"_IRTN_"(.XOBX,.XOBDATA)" |
2566 | +"RTN","XOBVRH",72,0) |
2567 | + IF $PIECE(TYPE0,U,1)]"" SET XOBHDLR("NAME",$PIECE(TYPE0,U,1),TYPE)="" |
2568 | +"RTN","XOBVRH",73,0) |
2569 | + IF $PIECE(TYPE0,U,2)]"" SET XOBHDLR("MSGTYPE",$PIECE(TYPE0,U,2),TYPE)="" |
2570 | +"RTN","XOBVRH",74,0) |
2571 | + IF $PIECE(TYPE0,U,7)]"" SET XOBHDLR("D",$PIECE(TYPE0,U,7),TYPE)="" |
2572 | +"RTN","XOBVRH",75,0) |
2573 | + ; |
2574 | +"RTN","XOBVRH",76,0) |
2575 | + ; -- set up SAX callbacks |
2576 | +"RTN","XOBVRH",77,0) |
2577 | + SET XOBHDLR(TYPE,"CB","ELEST")="QUIT" |
2578 | +"RTN","XOBVRH",78,0) |
2579 | + SET XOBHDLR(TYPE,"CB","ELEND")="QUIT" |
2580 | +"RTN","XOBVRH",79,0) |
2581 | + SET XOBHDLR(TYPE,"CB","CHR")="QUIT" |
2582 | +"RTN","XOBVRH",80,0) |
2583 | + ; |
2584 | +"RTN","XOBVRH",81,0) |
2585 | + XECUTE "DO CALLBACK^"_IRTN_"(.XOBICBK)" |
2586 | +"RTN","XOBVRH",82,0) |
2587 | + IF $DATA(XOBICBK("STARTELEMENT")) SET XOBHDLR(TYPE,"CB","ELEST")="DO "_XOBICBK("STARTELEMENT")_"(.ELE,.ATR)" |
2588 | +"RTN","XOBVRH",83,0) |
2589 | + IF $DATA(XOBICBK("ENDELEMENT")) SET XOBHDLR(TYPE,"CB","ELEND")="DO "_XOBICBK("ENDELEMENT")_"(.ELE)" |
2590 | +"RTN","XOBVRH",84,0) |
2591 | + IF $DATA(XOBICBK("CHARACTERS")) SET XOBHDLR(TYPE,"CB","CHR")="DO "_XOBICBK("CHARACTERS")_"(.TXT)" |
2592 | +"RTN","XOBVRH",85,0) |
2593 | +SETQ ; |
2594 | +"RTN","XOBVRH",86,0) |
2595 | + QUIT |
2596 | +"RTN","XOBVRH",87,0) |
2597 | + ; |
2598 | +"RTN","XOBVRH",88,0) |
2599 | + ; -- get interface routine and test for existence |
2600 | +"RTN","XOBVRH",89,0) |
2601 | +IRTN(XOBTYPE0) ; |
2602 | +"RTN","XOBVRH",90,0) |
2603 | + NEW X,RTN |
2604 | +"RTN","XOBVRH",91,0) |
2605 | + SET RTN="" |
2606 | +"RTN","XOBVRH",92,0) |
2607 | + SET X=$PIECE(XOBTYPE0,"^",5) |
2608 | +"RTN","XOBVRH",93,0) |
2609 | + IF X]"" DO |
2610 | +"RTN","XOBVRH",94,0) |
2611 | + . XECUTE ^%ZOSF("TEST") |
2612 | +"RTN","XOBVRH",95,0) |
2613 | + . IF $TEST SET RTN=X |
2614 | +"RTN","XOBVRH",96,0) |
2615 | + QUIT RTN |
2616 | +"RTN","XOBVRH",97,0) |
2617 | + ; |
2618 | +"RTN","XOBVSKT") |
2619 | +0^21^B19778790 |
2620 | +"RTN","XOBVSKT",1,0) |
2621 | +XOBVSKT ;; mjk/alb MSC/JDA- VistaLink Socket Methods ; 07/27/2002 13:00 |
2622 | +"RTN","XOBVSKT",2,0) |
2623 | + ;;1.5;VistALink;**MSC**;Sep 09, 2005 |
2624 | +"RTN","XOBVSKT",3,0) |
2625 | + ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026] |
2626 | +"RTN","XOBVSKT",4,0) |
2627 | + ; |
2628 | +"RTN","XOBVSKT",5,0) |
2629 | + QUIT |
2630 | +"RTN","XOBVSKT",6,0) |
2631 | + ; |
2632 | +"RTN","XOBVSKT",7,0) |
2633 | + ; ------------------------------------------------------------------------------------ |
2634 | +"RTN","XOBVSKT",8,0) |
2635 | + ; Methods for Read fromto TCP/IP Socket |
2636 | +"RTN","XOBVSKT",9,0) |
2637 | + ; ------------------------------------------------------------------------------------ |
2638 | +"RTN","XOBVSKT",10,0) |
2639 | +READ(XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBSTOP,XOBDATA,XOBHDLR) ; |
2640 | +"RTN","XOBVSKT",11,0) |
2641 | + NEW X,EOT,OUT,STR,LINE,PIECES,DONE,TOFLAG,XOBCNT,XOBLEN,XOBBH,XOBEH,BS,ES,XOBOK,XOBX |
2642 | +"RTN","XOBVSKT",12,0) |
2643 | + ; |
2644 | +"RTN","XOBVSKT",13,0) |
2645 | + SET STR="",EOT=$CHAR(4),DONE=0,LINE=0,XOBOK=1 |
2646 | +"RTN","XOBVSKT",14,0) |
2647 | + ; |
2648 | +"RTN","XOBVSKT",15,0) |
2649 | + ; -- READ tcp stream to global buffer | main calling tag NXTCALL^XOBVLL |
2650 | +"RTN","XOBVSKT",16,0) |
2651 | + FOR READ XOBX#XOBREAD:XOBTO SET TOFLAG=$TEST DO:XOBFIRST CHK DO:'XOBSTOP!('DONE) QUIT:DONE |
2652 | +"RTN","XOBVSKT",17,0) |
2653 | + . ; |
2654 | +"RTN","XOBVSKT",18,0) |
2655 | + . ; -- if length of (new intake + current) is too large for buffer then store current |
2656 | +"RTN","XOBVSKT",19,0) |
2657 | + . IF $LENGTH(STR)+$LENGTH(XOBX)>400 DO ADD(STR) SET STR="" |
2658 | +"RTN","XOBVSKT",20,0) |
2659 | + . SET STR=STR_XOBX |
2660 | +"RTN","XOBVSKT",21,0) |
2661 | + . ; |
2662 | +"RTN","XOBVSKT",22,0) |
2663 | + . ; -- add node at each line-feed character |
2664 | +"RTN","XOBVSKT",23,0) |
2665 | + . ; COMMENTED OUT: Not needed anymore, and has side effect of stripping out line feeds in input |
2666 | +"RTN","XOBVSKT",24,0) |
2667 | + . ; array-type parameter values (in XML mode) |
2668 | +"RTN","XOBVSKT",25,0) |
2669 | + . ; FOR QUIT:STR'[$CHAR(10) DO ADD($PIECE(STR,$CHAR(10))) SET STR=$PIECE(STR,$CHAR(10),2,999) |
2670 | +"RTN","XOBVSKT",26,0) |
2671 | + . ; |
2672 | +"RTN","XOBVSKT",27,0) |
2673 | + . ; -- if end-of-text marker found then wrap up and quit |
2674 | +"RTN","XOBVSKT",28,0) |
2675 | + . IF STR[EOT SET STR=$PIECE(STR,EOT) DO ADD(STR) SET DONE=1 QUIT |
2676 | +"RTN","XOBVSKT",29,0) |
2677 | + . ; |
2678 | +"RTN","XOBVSKT",30,0) |
2679 | + . ; -- M XML parser cannot handle an element name split across nodes |
2680 | +"RTN","XOBVSKT",31,0) |
2681 | + . SET PIECES=$LENGTH(STR,">") |
2682 | +"RTN","XOBVSKT",32,0) |
2683 | + . IF PIECES>1 DO ADD($PIECE(STR,">",1,PIECES-1)_">") SET STR=$PIECE(STR,">",PIECES,999) |
2684 | +"RTN","XOBVSKT",33,0) |
2685 | + ; |
2686 | +"RTN","XOBVSKT",34,0) |
2687 | + QUIT XOBOK |
2688 | +"RTN","XOBVSKT",35,0) |
2689 | + ; |
2690 | +"RTN","XOBVSKT",36,0) |
2691 | +ADD(TXT) ; -- add new intake line |
2692 | +"RTN","XOBVSKT",37,0) |
2693 | + SET LINE=LINE+1 |
2694 | +"RTN","XOBVSKT",38,0) |
2695 | + SET @XOBROOT@(LINE)=TXT |
2696 | +"RTN","XOBVSKT",39,0) |
2697 | + QUIT |
2698 | +"RTN","XOBVSKT",40,0) |
2699 | + ; |
2700 | +"RTN","XOBVSKT",41,0) |
2701 | +CHK ; -- check if first read and change timeout and chars to read |
2702 | +"RTN","XOBVSKT",42,0) |
2703 | + SET XOBFIRST=0 |
2704 | +"RTN","XOBVSKT",43,0) |
2705 | + ; |
2706 | +"RTN","XOBVSKT",44,0) |
2707 | + ; -- abort if time out occurred and nothing was read |
2708 | +"RTN","XOBVSKT",45,0) |
2709 | + IF 'TOFLAG,$GET(XOBX)="" SET XOBSTOP=1,DONE=1,XOBOK=0 QUIT |
2710 | +"RTN","XOBVSKT",46,0) |
2711 | + ; |
2712 | +"RTN","XOBVSKT",47,0) |
2713 | + ; -- intercept for transport sinks |
2714 | +"RTN","XOBVSKT",48,0) |
2715 | + IF $EXTRACT(XOBX)'="<" DO SINK |
2716 | +"RTN","XOBVSKT",49,0) |
2717 | + ; |
2718 | +"RTN","XOBVSKT",50,0) |
2719 | + ; -- set up for subsequent reads |
2720 | +"RTN","XOBVSKT",51,0) |
2721 | + SET XOBREAD=200,XOBTO=1 |
2722 | +"RTN","XOBVSKT",52,0) |
2723 | + QUIT |
2724 | +"RTN","XOBVSKT",53,0) |
2725 | + ; |
2726 | +"RTN","XOBVSKT",54,0) |
2727 | + ; ------------------------------------------------------------------------------------ |
2728 | +"RTN","XOBVSKT",55,0) |
2729 | + ; Execute Proprietary Format Reader |
2730 | +"RTN","XOBVSKT",56,0) |
2731 | + ; ------------------------------------------------------------------------------------ |
2732 | +"RTN","XOBVSKT",57,0) |
2733 | +SINK ; |
2734 | +"RTN","XOBVSKT",58,0) |
2735 | + ; -- get size of sink indicator >> then get sink indicator >> load req handler |
2736 | +"RTN","XOBVSKT",59,0) |
2737 | + SET XOBHDLR=$$MSGSINK^XOBVRH($$GETSTR(+$$GETSTR(2,.XOBX),.XOBX),.XOBHDLR) |
2738 | +"RTN","XOBVSKT",60,0) |
2739 | + ; |
2740 | +"RTN","XOBVSKT",61,0) |
2741 | + ; -- execute proprietary stream reader |
2742 | +"RTN","XOBVSKT",62,0) |
2743 | + IF $GET(XOBHDLR(XOBHDLR)) XECUTE $GET(XOBHDLR(XOBHDLR,"READER")) |
2744 | +"RTN","XOBVSKT",63,0) |
2745 | + ; |
2746 | +"RTN","XOBVSKT",64,0) |
2747 | + SET DONE=1 |
2748 | +"RTN","XOBVSKT",65,0) |
2749 | + QUIT |
2750 | +"RTN","XOBVSKT",66,0) |
2751 | + ; |
2752 | +"RTN","XOBVSKT",67,0) |
2753 | + ; -- get string of length LEN from stream buffer |
2754 | +"RTN","XOBVSKT",68,0) |
2755 | +GETSTR(LEN,XOBUF) ; |
2756 | +"RTN","XOBVSKT",69,0) |
2757 | + NEW X |
2758 | +"RTN","XOBVSKT",70,0) |
2759 | + FOR QUIT:($LENGTH(XOBUF)'<LEN) DO RMORE(LEN-$LENGTH(XOBUF),.XOBUF) |
2760 | +"RTN","XOBVSKT",71,0) |
2761 | + SET X=$EXTRACT(XOBUF,1,LEN) |
2762 | +"RTN","XOBVSKT",72,0) |
2763 | + SET XOBUF=$EXTRACT(XOBUF,LEN+1,999) |
2764 | +"RTN","XOBVSKT",73,0) |
2765 | + QUIT X |
2766 | +"RTN","XOBVSKT",74,0) |
2767 | + ; |
2768 | +"RTN","XOBVSKT",75,0) |
2769 | + ; -- read more from stream buffer but only needed amount |
2770 | +"RTN","XOBVSKT",76,0) |
2771 | +RMORE(LEN,XOBUF) ; |
2772 | +"RTN","XOBVSKT",77,0) |
2773 | + NEW X |
2774 | +"RTN","XOBVSKT",78,0) |
2775 | + READ X#LEN:1 SET XOBUF=XOBUF_X |
2776 | +"RTN","XOBVSKT",79,0) |
2777 | + QUIT |
2778 | +"RTN","XOBVSKT",80,0) |
2779 | + ; |
2780 | +"RTN","XOBVSKT",81,0) |
2781 | + ; ------------------------------------------------------------------------------------ |
2782 | +"RTN","XOBVSKT",82,0) |
2783 | + ; Methods for Openning and Closing Socket |
2784 | +"RTN","XOBVSKT",83,0) |
2785 | + ; ------------------------------------------------------------------------------------ |
2786 | +"RTN","XOBVSKT",84,0) |
2787 | +OPEN(XOBPARMS) ; -- Open tcp/ip socket |
2788 | +"RTN","XOBVSKT",85,0) |
2789 | + NEW I,POP |
2790 | +"RTN","XOBVSKT",86,0) |
2791 | + SET POP=1 |
2792 | +"RTN","XOBVSKT",87,0) |
2793 | + ; |
2794 | +"RTN","XOBVSKT",88,0) |
2795 | + ; -- set up os var |
2796 | +"RTN","XOBVSKT",89,0) |
2797 | + DO OS |
2798 | +"RTN","XOBVSKT",90,0) |
2799 | + ; |
2800 | +"RTN","XOBVSKT",91,0) |
2801 | + ; -- preserve client io |
2802 | +"RTN","XOBVSKT",92,0) |
2803 | + DO SAVDEV^%ZISUTL("XOB CLIENT") |
2804 | +"RTN","XOBVSKT",93,0) |
2805 | + ; |
2806 | +"RTN","XOBVSKT",94,0) |
2807 | + FOR I=1:1:XOBPARMS("RETRIES") DO CALL^%ZISTCP(XOBPARMS("ADDRESS"),XOBPARMS("PORT")) QUIT:'POP |
2808 | +"RTN","XOBVSKT",95,0) |
2809 | + ; -- device open |
2810 | +"RTN","XOBVSKT",96,0) |
2811 | + IF 'POP USE IO QUIT 1 |
2812 | +"RTN","XOBVSKT",97,0) |
2813 | + ; -- device not open |
2814 | +"RTN","XOBVSKT",98,0) |
2815 | + QUIT 0 |
2816 | +"RTN","XOBVSKT",99,0) |
2817 | + ; |
2818 | +"RTN","XOBVSKT",100,0) |
2819 | +CLOSE(XOBPARMS) ; -- close tcp/ip socket |
2820 | +"RTN","XOBVSKT",101,0) |
2821 | + ; -- tell server to Stop() connection if close message is needed to close |
2822 | +"RTN","XOBVSKT",102,0) |
2823 | + IF $GET(XOBPARMS("CLOSE MESSAGE"))]"" DO |
2824 | +"RTN","XOBVSKT",103,0) |
2825 | + . DO PRE |
2826 | +"RTN","XOBVSKT",104,0) |
2827 | + . DO WRITE($$XMLHDR^XOBVLIB()_XOBPARMS("CLOSE MESSAGE")) |
2828 | +"RTN","XOBVSKT",105,0) |
2829 | + . DO POST |
2830 | +"RTN","XOBVSKT",106,0) |
2831 | + ; |
2832 | +"RTN","XOBVSKT",107,0) |
2833 | + DO FINAL |
2834 | +"RTN","XOBVSKT",108,0) |
2835 | + DO CLOSE^%ZISTCP |
2836 | +"RTN","XOBVSKT",109,0) |
2837 | + DO USE^%ZISUTL("XOB CLIENT") |
2838 | +"RTN","XOBVSKT",110,0) |
2839 | + DO RMDEV^%ZISUTL("XOB CLIENT") |
2840 | +"RTN","XOBVSKT",111,0) |
2841 | + QUIT |
2842 | +"RTN","XOBVSKT",112,0) |
2843 | + ; |
2844 | +"RTN","XOBVSKT",113,0) |
2845 | +INIT ; -- set up variables needed in tcp/ip processing |
2846 | +"RTN","XOBVSKT",114,0) |
2847 | + KILL XOBNULL |
2848 | +"RTN","XOBVSKT",115,0) |
2849 | + ; |
2850 | +"RTN","XOBVSKT",116,0) |
2851 | + ; -- setup os var |
2852 | +"RTN","XOBVSKT",117,0) |
2853 | + DO OS |
2854 | +"RTN","XOBVSKT",118,0) |
2855 | + ; |
2856 | +"RTN","XOBVSKT",119,0) |
2857 | + ; -- set RPC Broker os variable (so $$BROKER^XWBLIB returns true) |
2858 | +"RTN","XOBVSKT",120,0) |
2859 | + SET XWBOS=XOBOS |
2860 | +"RTN","XOBVSKT",121,0) |
2861 | + ; |
2862 | +"RTN","XOBVSKT",122,0) |
2863 | + ; -- setup null device called "NULL" |
2864 | +"RTN","XOBVSKT",123,0) |
2865 | + SET %ZIS="0H",IOP="NULL" DO ^%ZIS |
2866 | +"RTN","XOBVSKT",124,0) |
2867 | + IF 'POP DO |
2868 | +"RTN","XOBVSKT",125,0) |
2869 | + . SET XOBNULL=IO |
2870 | +"RTN","XOBVSKT",126,0) |
2871 | + . DO SAVDEV^%ZISUTL("XOBNULL") |
2872 | +"RTN","XOBVSKT",127,0) |
2873 | + QUIT |
2874 | +"RTN","XOBVSKT",128,0) |
2875 | + ; |
2876 | +"RTN","XOBVSKT",129,0) |
2877 | +OS ; -- os var |
2878 | +"RTN","XOBVSKT",130,0) |
2879 | + SET XOBOS=$SELECT(^%ZOSF("OS")["OpenM":"OpenM",^("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["MSM":"MSM",1:"") |
2880 | +"RTN","XOBVSKT",131,0) |
2881 | + QUIT |
2882 | +"RTN","XOBVSKT",132,0) |
2883 | + ; |
2884 | +"RTN","XOBVSKT",133,0) |
2885 | +FINAL ; -- kill variables used in tcp/ip processing |
2886 | +"RTN","XOBVSKT",134,0) |
2887 | + ; |
2888 | +"RTN","XOBVSKT",135,0) |
2889 | + ; -- close null device |
2890 | +"RTN","XOBVSKT",136,0) |
2891 | + IF $DATA(XOBNULL) DO |
2892 | +"RTN","XOBVSKT",137,0) |
2893 | + . DO USE^%ZISUTL("XOBNULL") |
2894 | +"RTN","XOBVSKT",138,0) |
2895 | + . DO CLOSE^%ZISUTL("XOBNULL") |
2896 | +"RTN","XOBVSKT",139,0) |
2897 | + . KILL XOBNULL |
2898 | +"RTN","XOBVSKT",140,0) |
2899 | + ; |
2900 | +"RTN","XOBVSKT",141,0) |
2901 | + KILL XOBOS,XWBOS |
2902 | +"RTN","XOBVSKT",142,0) |
2903 | + ; |
2904 | +"RTN","XOBVSKT",143,0) |
2905 | + QUIT |
2906 | +"RTN","XOBVSKT",144,0) |
2907 | + ; |
2908 | +"RTN","XOBVSKT",145,0) |
2909 | + ; ------------------------------------------------------------------------------------ |
2910 | +"RTN","XOBVSKT",146,0) |
2911 | + ; Methods for Writing to TCP/IP Socket |
2912 | +"RTN","XOBVSKT",147,0) |
2913 | + ; ------------------------------------------------------------------------------------ |
2914 | +"RTN","XOBVSKT",148,0) |
2915 | +PRE ; -- prepare socket for writing |
2916 | +"RTN","XOBVSKT",149,0) |
2917 | + SET $X=0 |
2918 | +"RTN","XOBVSKT",150,0) |
2919 | + QUIT |
2920 | +"RTN","XOBVSKT",151,0) |
2921 | + ; |
2922 | +"RTN","XOBVSKT",152,0) |
2923 | +WRITE(STR) ; -- Write a data string to socket |
2924 | +"RTN","XOBVSKT",153,0) |
2925 | + IF XOBOS="MSM" WRITE STR QUIT |
2926 | +"RTN","XOBVSKT",154,0) |
2927 | + ; |
2928 | +"RTN","XOBVSKT",155,0) |
2929 | + ; -- handle a short string |
2930 | +"RTN","XOBVSKT",156,0) |
2931 | + IF $LENGTH(STR)<511 DO:($X+$LENGTH(STR))>511 FLUSH WRITE STR QUIT |
2932 | +"RTN","XOBVSKT",157,0) |
2933 | + ; |
2934 | +"RTN","XOBVSKT",158,0) |
2935 | + ; -- handle a long string |
2936 | +"RTN","XOBVSKT",159,0) |
2937 | + DO FLUSH |
2938 | +"RTN","XOBVSKT",160,0) |
2939 | + FOR QUIT:'$LENGTH(STR) WRITE $EXTRACT(STR,1,511) DO FLUSH SET STR=$EXTRACT(STR,512,99999) |
2940 | +"RTN","XOBVSKT",161,0) |
2941 | + ; |
2942 | +"RTN","XOBVSKT",162,0) |
2943 | + QUIT |
2944 | +"RTN","XOBVSKT",163,0) |
2945 | + ; |
2946 | +"RTN","XOBVSKT",164,0) |
2947 | +POST ; -- send eot and flush socket buffer |
2948 | +"RTN","XOBVSKT",165,0) |
2949 | + DO WRITE($CHAR(4)) |
2950 | +"RTN","XOBVSKT",166,0) |
2951 | + DO FLUSH |
2952 | +"RTN","XOBVSKT",167,0) |
2953 | + QUIT |
2954 | +"RTN","XOBVSKT",168,0) |
2955 | + ; |
2956 | +"RTN","XOBVSKT",169,0) |
2957 | +FLUSH ; flush buffer |
2958 | +"RTN","XOBVSKT",170,0) |
2959 | + IF XOBOS="OpenM" WRITE ! QUIT |
2960 | +"RTN","XOBVSKT",171,0) |
2961 | + IF XOBOS="DSM" WRITE:$X>0 ! QUIT |
2962 | +"RTN","XOBVSKT",172,0) |
2963 | + IF XOBOS="GTM" WRITE # QUIT |
2964 | +"RTN","XOBVSKT",173,0) |
2965 | + QUIT |
2966 | +"RTN","XOBVSKT",174,0) |
2967 | + ; |
2968 | +"RTN","XOBVTCPL") |
2969 | +0^22^B13529543 |
2970 | +"RTN","XOBVTCPL",1,0) |
2971 | +XOBVTCPL ;; mjk/alb MSC/JDA - VistALink TCP/IP Listener (Cache NT) ; 07/27/2002 13:00 |
2972 | +"RTN","XOBVTCPL",2,0) |
2973 | + ;;1.5;VistALink;**MSC**;Sep 09, 2005 |
2974 | +"RTN","XOBVTCPL",3,0) |
2975 | + ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026] |
2976 | +"RTN","XOBVTCPL",4,0) |
2977 | + ; |
2978 | +"RTN","XOBVTCPL",5,0) |
2979 | + QUIT |
2980 | +"RTN","XOBVTCPL",6,0) |
2981 | + ; |
2982 | +"RTN","XOBVTCPL",7,0) |
2983 | + ; -- Important: Should always be JOBed using START^XOBVTCP |
2984 | +"RTN","XOBVTCPL",8,0) |
2985 | +LISTENER(XOBPORT,XOBCFG) ; -- Start Listener |
2986 | +"RTN","XOBVTCPL",9,0) |
2987 | + ; |
2988 | +"RTN","XOBVTCPL",10,0) |
2989 | + N OS |
2990 | +"RTN","XOBVTCPL",11,0) |
2991 | + S OS=$$GETOS^XOBVTCP() |
2992 | +"RTN","XOBVTCPL",12,0) |
2993 | + ; -- quit if not Cache for NT or GT.M |
2994 | +"RTN","XOBVTCPL",13,0) |
2995 | + IF (OS'="OpenM-NT")&(OS'["GT.M") QUIT |
2996 | +"RTN","XOBVTCPL",14,0) |
2997 | + ; |
2998 | +"RTN","XOBVTCPL",15,0) |
2999 | + NEW $ETRAP,$ESTACK SET $ETRAP="D ^%ZTER HALT" |
3000 | +"RTN","XOBVTCPL",16,0) |
3001 | + ; |
3002 | +"RTN","XOBVTCPL",17,0) |
3003 | + NEW X,POP,XOBDA,U,DTIME,DT,XOBIO |
3004 | +"RTN","XOBVTCPL",18,0) |
3005 | + SET U="^",DTIME=900,DT=$$DT^XLFDT() |
3006 | +"RTN","XOBVTCPL",19,0) |
3007 | + IF $GET(DUZ)="" NEW DUZ SET DUZ=.5,DUZ(0)="@" |
3008 | +"RTN","XOBVTCPL",20,0) |
3009 | + ; |
3010 | +"RTN","XOBVTCPL",21,0) |
3011 | + ; -- only start if not already started |
3012 | +"RTN","XOBVTCPL",22,0) |
3013 | + IF $$LOCK^XOBVTCP(XOBPORT) DO |
3014 | +"RTN","XOBVTCPL",23,0) |
3015 | + . IF $$OPEN(.XOBIO,XOBPORT,OS) DO |
3016 | +"RTN","XOBVTCPL",24,0) |
3017 | + . . ; -- listener started and now stopping |
3018 | +"RTN","XOBVTCPL",25,0) |
3019 | + . . SET IO=XOBIO |
3020 | +"RTN","XOBVTCPL",26,0) |
3021 | + . . DO CLOSE^%ZISTCP |
3022 | +"RTN","XOBVTCPL",27,0) |
3023 | + . . ; -- update status to 'stopped' |
3024 | +"RTN","XOBVTCPL",28,0) |
3025 | + . . DO UPDATE^XOBVTCP(XOBPORT,4,$GET(XOBCFG)) |
3026 | +"RTN","XOBVTCPL",29,0) |
3027 | + . ELSE DO |
3028 | +"RTN","XOBVTCPL",30,0) |
3029 | + . . ; -- listener failed to start |
3030 | +"RTN","XOBVTCPL",31,0) |
3031 | + . . ; -- update status to 'failed' |
3032 | +"RTN","XOBVTCPL",32,0) |
3033 | + . . DO UPDATE^XOBVTCP(XOBPORT,5,$GET(XOBCFG)) |
3034 | +"RTN","XOBVTCPL",33,0) |
3035 | + . ; |
3036 | +"RTN","XOBVTCPL",34,0) |
3037 | + . DO UNLOCK^XOBVTCP(XOBPORT) |
3038 | +"RTN","XOBVTCPL",35,0) |
3039 | + QUIT |
3040 | +"RTN","XOBVTCPL",36,0) |
3041 | + ; |
3042 | +"RTN","XOBVTCPL",37,0) |
3043 | + ; -- open/start listener port |
3044 | +"RTN","XOBVTCPL",38,0) |
3045 | +OPEN(XOBIO,XOBPORT,OS) ; |
3046 | +"RTN","XOBVTCPL",39,0) |
3047 | + Q $S(OS="OpenM-NT":$$OPENM(.XOBIO,XOBPORT),OS["GT.M":$$OPENGTM(.XOBIO,XOBPORT),1:0) |
3048 | +"RTN","XOBVTCPL",40,0) |
3049 | + ; |
3050 | +"RTN","XOBVTCPL",41,0) |
3051 | + ; -- open/start listener port on Cache |
3052 | +"RTN","XOBVTCPL",42,0) |
3053 | +OPENM(XOBIO,XOBPORT) ; |
3054 | +"RTN","XOBVTCPL",43,0) |
3055 | + NEW XOBBOX,%ZA |
3056 | +"RTN","XOBVTCPL",44,0) |
3057 | + SET XOBBOX=+$$GETBOX^XOBVTCP() |
3058 | +"RTN","XOBVTCPL",45,0) |
3059 | + SET XOBIO="|TCP|"_XOBPORT |
3060 | +"RTN","XOBVTCPL",46,0) |
3061 | + X "OPEN XOBIO:(:XOBPORT:""AT""):30" |
3062 | +"RTN","XOBVTCPL",47,0) |
3063 | + ; |
3064 | +"RTN","XOBVTCPL",48,0) |
3065 | + ; -- if listener port could not be openned then gracefully quit |
3066 | +"RTN","XOBVTCPL",49,0) |
3067 | + ; (other namespace using port maybe?) |
3068 | +"RTN","XOBVTCPL",50,0) |
3069 | + IF '$TEST QUIT 0 |
3070 | +"RTN","XOBVTCPL",51,0) |
3071 | + ; |
3072 | +"RTN","XOBVTCPL",52,0) |
3073 | + ; -- indicate listener is 'running' |
3074 | +"RTN","XOBVTCPL",53,0) |
3075 | + DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG)) |
3076 | +"RTN","XOBVTCPL",54,0) |
3077 | + ; -- read & spawn loop |
3078 | +"RTN","XOBVTCPL",55,0) |
3079 | + FOR DO QUIT:$$EXIT(XOBBOX,XOBPORT) |
3080 | +"RTN","XOBVTCPL",56,0) |
3081 | + . USE XOBIO |
3082 | +"RTN","XOBVTCPL",57,0) |
3083 | + . READ *X:60 IF '$TEST QUIT |
3084 | +"RTN","XOBVTCPL",58,0) |
3085 | + . X "JOB CHILD^XOBVTCPL():(:4:XOBIO:XOBIO):10" SET %ZA=$ZA |
3086 | +"RTN","XOBVTCPL",59,0) |
3087 | + . IF %ZA\8196#2=1 WRITE *-2 ;Job failed to clear bit |
3088 | +"RTN","XOBVTCPL",60,0) |
3089 | + QUIT 1 |
3090 | +"RTN","XOBVTCPL",61,0) |
3091 | + ; |
3092 | +"RTN","XOBVTCPL",62,0) |
3093 | + ; -- open/start listener port on GT.M |
3094 | +"RTN","XOBVTCPL",63,0) |
3095 | +OPENGTM(XOBIO,XOBPORT) ; |
3096 | +"RTN","XOBVTCPL",64,0) |
3097 | + NEW XOBBOX |
3098 | +"RTN","XOBVTCPL",65,0) |
3099 | + SET XOBBOX=+$$GETBOX^XOBVTCP() |
3100 | +"RTN","XOBVTCPL",66,0) |
3101 | + SET XOBIO="|TCP|"_XOBPORT_"|"_$J |
3102 | +"RTN","XOBVTCPL",67,0) |
3103 | + OPEN XOBIO:(ZLISTEN=XOBPORT_":TCP":ATTACH="LISTENER"):5:"SOCKET" |
3104 | +"RTN","XOBVTCPL",68,0) |
3105 | + ; |
3106 | +"RTN","XOBVTCPL",69,0) |
3107 | + ; -- if listener port could not be openned then gracefully quit |
3108 | +"RTN","XOBVTCPL",70,0) |
3109 | + ; (other namespace using port maybe?) |
3110 | +"RTN","XOBVTCPL",71,0) |
3111 | + IF '$TEST QUIT 0 |
3112 | +"RTN","XOBVTCPL",72,0) |
3113 | + ; |
3114 | +"RTN","XOBVTCPL",73,0) |
3115 | + ; -- indicate listener is 'running' |
3116 | +"RTN","XOBVTCPL",74,0) |
3117 | + DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG)) |
3118 | +"RTN","XOBVTCPL",75,0) |
3119 | + D LISTEN^ZISTCPS(XOBPORT,"CHILD^XOBVTCPL","EXIT^XOBVTCPL("_XOBBOX_","_XOBPORT_")") |
3120 | +"RTN","XOBVTCPL",76,0) |
3121 | + ; |
3122 | +"RTN","XOBVTCPL",77,0) |
3123 | +CHILD ;Child process |
3124 | +"RTN","XOBVTCPL",78,0) |
3125 | + NEW XOBEC |
3126 | +"RTN","XOBVTCPL",79,0) |
3127 | + SET $ETRAP="D ^%ZTER L HALT" |
3128 | +"RTN","XOBVTCPL",80,0) |
3129 | + SET IO=$PRINCIPAL ;Reset IO to be $P |
3130 | +"RTN","XOBVTCPL",81,0) |
3131 | + IF $$GETOS^XOBVTCP()["OpenM" X "USE IO:(::""-M"")" ;Packet mode like DSM |
3132 | +"RTN","XOBVTCPL",82,0) |
3133 | + ; -- do quit to save a stack level |
3134 | +"RTN","XOBVTCPL",83,0) |
3135 | + SET XOBEC=$$NEWOK() |
3136 | +"RTN","XOBVTCPL",84,0) |
3137 | + IF XOBEC DO LOGINERR(XOBEC,IO) |
3138 | +"RTN","XOBVTCPL",85,0) |
3139 | + IF 'XOBEC DO VAR,SPAWN^XOBVLL |
3140 | +"RTN","XOBVTCPL",86,0) |
3141 | + QUIT |
3142 | +"RTN","XOBVTCPL",87,0) |
3143 | + ; |
3144 | +"RTN","XOBVTCPL",88,0) |
3145 | +VAR ;Setup IO variables |
3146 | +"RTN","XOBVTCPL",89,0) |
3147 | + SET IO(0)=IO,IO(1,IO)="",POP=0 |
3148 | +"RTN","XOBVTCPL",90,0) |
3149 | + SET IOT="TCP",IOF="#",IOST="P-TCP",IOST(0)=0 |
3150 | +"RTN","XOBVTCPL",91,0) |
3151 | + QUIT |
3152 | +"RTN","XOBVTCPL",92,0) |
3153 | + ; |
3154 | +"RTN","XOBVTCPL",93,0) |
3155 | +NEWOK() ;Is it OK to start a new process |
3156 | +"RTN","XOBVTCPL",94,0) |
3157 | + NEW XQVOL,XUVOL,X,XOBCODE,Y |
3158 | +"RTN","XOBVTCPL",95,0) |
3159 | + SET U="^" |
3160 | +"RTN","XOBVTCPL",96,0) |
3161 | + DO GETENV^%ZOSV SET XQVOL=$PIECE(Y,U,2) |
3162 | +"RTN","XOBVTCPL",97,0) |
3163 | + SET X=$$FIND1^DIC(8989.304,",1,","BX",XQVOL,"","",""),XUVOL=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1") |
3164 | +"RTN","XOBVTCPL",98,0) |
3165 | + SET XOBCODE=$$INHIBIT^XUSRB() |
3166 | +"RTN","XOBVTCPL",99,0) |
3167 | + IF XOBCODE=1 QUIT 181004 |
3168 | +"RTN","XOBVTCPL",100,0) |
3169 | + IF XOBCODE=2 QUIT 181003 |
3170 | +"RTN","XOBVTCPL",101,0) |
3171 | + QUIT 0 |
3172 | +"RTN","XOBVTCPL",102,0) |
3173 | + ; |
3174 | +"RTN","XOBVTCPL",103,0) |
3175 | + ; -- process error |
3176 | +"RTN","XOBVTCPL",104,0) |
3177 | +LOGINERR(XOBEC,XOBPORT) ; |
3178 | +"RTN","XOBVTCPL",105,0) |
3179 | + DO ERROR^XOBVLL(XOBEC,$$EZBLD^DIALOG(XOBEC),XOBPORT) |
3180 | +"RTN","XOBVTCPL",106,0) |
3181 | + ; |
3182 | +"RTN","XOBVTCPL",107,0) |
3183 | + ; -- give client time to process stream |
3184 | +"RTN","XOBVTCPL",108,0) |
3185 | + HANG 2 |
3186 | +"RTN","XOBVTCPL",109,0) |
3187 | + QUIT |
3188 | +"RTN","XOBVTCPL",110,0) |
3189 | + ; |
3190 | +"RTN","XOBVTCPL",111,0) |
3191 | +EXIT(XOBBOX,XOBPORT) ; |
3192 | +"RTN","XOBVTCPL",112,0) |
3193 | + ; -- is status 'stopping' |
3194 | +"RTN","XOBVTCPL",113,0) |
3195 | + SET ZISQUIT=$PIECE($GET(^XOB(18.04,+$$GETLOGID(XOBBOX,XOBPORT),0)),U,3)=3 |
3196 | +"RTN","XOBVTCPL",114,0) |
3197 | + Q ZISQUIT |
3198 | +"RTN","XOBVTCPL",115,0) |
3199 | + ; |
3200 | +"RTN","XOBVTCPL",116,0) |
3201 | +GETLOGID(XOBBOX,XOBPORT) ; |
3202 | +"RTN","XOBVTCPL",117,0) |
3203 | + QUIT +$ORDER(^XOB(18.04,"C",XOBBOX,XOBPORT,"")) |
3204 | +"RTN","XOBVTCPL",118,0) |
3205 | + ; |
3206 | +"RTN","XTER1A") |
3207 | +0^7^B29045171 |
3208 | +"RTN","XTER1A",1,0) |
3209 | +XTER1A ;ISC-SF.SEA/JLI - VA error reporting ;28MAR2006 |
3210 | +"RTN","XTER1A",2,0) |
3211 | + ;;8.0;KERNEL;**63,112,120,MSC,IHS**;Jul 10, 1995 |
3212 | +"RTN","XTER1A",3,0) |
3213 | + ; |
3214 | +"RTN","XTER1A",4,0) |
3215 | +TWO ; |
3216 | +"RTN","XTER1A",5,0) |
3217 | + S XTNUM=2 |
3218 | +"RTN","XTER1A",6,0) |
3219 | +ONE ; |
3220 | +"RTN","XTER1A",7,0) |
3221 | + S:'$D(XTNUM) XTNUM=1 |
3222 | +"RTN","XTER1A",8,0) |
3223 | + S:'$D(XTNDATE) XTNDATE=$H-1 I '$D(ZTQUEUED) S XTNDAT1=$$HTFM^XLFDT(XTNDATE),XTNDAT2=XTNDAT1 G INT^XTER1A1 |
3224 | +"RTN","XTER1A",9,0) |
3225 | + K ^TMP($J,"XTER1A") D LISTN,LIST |
3226 | +"RTN","XTER1A",10,0) |
3227 | +EXIT K XTNUM,XTNDATE,XTERN,XTERX,X,N,N1,Y,C,XTOUT,Z,I,XTER1AX,XTER1AN,XTER1AN1,%XTZDAT,%XTZNUM,XTMES,XTDV1,XTMES,XTPRNT |
3228 | +"RTN","XTER1A",11,0) |
3229 | + Q |
3230 | +"RTN","XTER1A",12,0) |
3231 | +LISTN ; |
3232 | +"RTN","XTER1A",13,0) |
3233 | + F XTERN=0:0 S XTERN=$O(^%ZTER(1,XTNDATE,1,XTERN)) Q:XTERN'>0 I $D(^(XTERN,"ZE")) S XTERX=$E(^("ZE"),1,30),X=^("ZE") D |
3234 | +"RTN","XTER1A",14,0) |
3235 | + .S N1=0 F N=0:0 S N=$O(^TMP($J,"XTER1A",XTERX,N)) Q:N="" S N1=N I ^(N)=X Q |
3236 | +"RTN","XTER1A",15,0) |
3237 | + .I N="" S ^TMP($J,"XTER1A",XTERX,N1+1)=X,^(N1+1,"CNT")=1,^(1)=XTNDATE_U_XTERN |
3238 | +"RTN","XTER1A",16,0) |
3239 | + .E S ^("CNT")=^TMP($J,"XTER1A",XTERX,N,"CNT")+1 I ^("CNT")'>XTNUM S Y=^("CNT"),^(Y)=XTNDATE_U_XTERN |
3240 | +"RTN","XTER1A",17,0) |
3241 | + .Q |
3242 | +"RTN","XTER1A",18,0) |
3243 | + Q |
3244 | +"RTN","XTER1A",19,0) |
3245 | +LIST ; |
3246 | +"RTN","XTER1A",20,0) |
3247 | + S XTERX="",C=0,XTOUT=0 K ^TMP($J,"XTER") |
3248 | +"RTN","XTER1A",21,0) |
3249 | + F S XTERX=$O(^TMP($J,"XTER1A",XTERX)) Q:XTERX="" F N=0:0 S N=$O(^TMP($J,"XTER1A",XTERX,N)) Q:N'>0 D |
3250 | +"RTN","XTER1A",22,0) |
3251 | + .S X=^TMP($J,"XTER1A",XTERX,N) S C=C+1,^TMP($J,"XTER",C)="",C=C+1,^(C)="",Z=$J(^TMP($J,"XTER1A",XTERX,N,"CNT"),8)_" " |
3252 | +"RTN","XTER1A",23,0) |
3253 | + .F I=1:60 S Y=$E(X,I,I+59) Q:Y="" S C=C+1,^TMP($J,"XTER",C)=Z_Y,Z=" " |
3254 | +"RTN","XTER1A",24,0) |
3255 | + S XTER1AX="" F S XTER1AX=$O(^TMP($J,"XTER1A",XTER1AX)) Q:XTER1AX="" F XTER1AN=0:0 S XTER1AN=$O(^TMP($J,"XTER1A",XTER1AX,XTER1AN)) Q:XTER1AN'>0 D |
3256 | +"RTN","XTER1A",25,0) |
3257 | + .F XTER1AN1=0:0 S XTER1AN1=$O(^TMP($J,"XTER1A",XTER1AX,XTER1AN,XTER1AN1)) Q:XTER1AN1'>0 S X=^(XTER1AN1) D |
3258 | +"RTN","XTER1A",26,0) |
3259 | + ..S C=C+1,^TMP($J,"XTER",C)="|PAGE|" S %XTZDAT=+X,%XTZNUM=$P(X,U,2),XTDV1=0 S XTMES=1 D WRT^XTER1 |
3260 | +"RTN","XTER1A",27,0) |
3261 | + D:IO=""&$D(^TMP($J,"XTER")) MESSG D:IO'="" WRITER |
3262 | +"RTN","XTER1A",28,0) |
3263 | + K ^TMP($J,"XTER") S C=0 I IO'="" U IO D ^%ZISC |
3264 | +"RTN","XTER1A",29,0) |
3265 | + Q |
3266 | +"RTN","XTER1A",30,0) |
3267 | + ; |
3268 | +"RTN","XTER1A",31,0) |
3269 | +MESG N DWPK,DWLW,DIC K ^TMP($J,"XTER"),^TMP($J,"XTER1") |
3270 | +"RTN","XTER1A",32,0) |
3271 | + W @IOF,!!,"Enter any comments to precede the error listing:" |
3272 | +"RTN","XTER1A",33,0) |
3273 | + S DWPK=1,DWLW=75,DIC="^TMP($J,""XTER1""," D EN^DIWE |
3274 | +"RTN","XTER1A",34,0) |
3275 | + S C=0 W ! F I=0:0 S I=$O(^TMP($J,"XTER1",I)) Q:I'>0 S C=I,^TMP($J,"XTER",I)=^TMP($J,"XTER1",I,0) |
3276 | +"RTN","XTER1A",35,0) |
3277 | + S XTMES=1,XTDV1=0 D WRT^XTER1 D:C>0 MESSG |
3278 | +"RTN","XTER1A",36,0) |
3279 | + S C=0 K XTMES,^TMP($J,"XTER"),^TMP($J,"XTER1") |
3280 | +"RTN","XTER1A",37,0) |
3281 | + G XTERR^XTER |
3282 | +"RTN","XTER1A",38,0) |
3283 | + ; |
3284 | +"RTN","XTER1A",39,0) |
3285 | +PRNT K ^TMP($J,"XTER"),ZTIO |
3286 | +"RTN","XTER1A",40,0) |
3287 | + S C=0,%ZIS="MQ" D ^%ZIS I POP D HOME^%ZIS G WRT^XTER1 |
3288 | +"RTN","XTER1A",41,0) |
3289 | + I $D(IO("Q")) D S XTX="" G XTERR^XTER |
3290 | +"RTN","XTER1A",42,0) |
3291 | + . K IO("Q") S ZTRTN="DQPRNT^XTER1A",ZTSAVE("%XTZDAT")="",ZTSAVE("%XTZNUM")="",ZTDESC="XTER1A-PRINT OF ERROR" D ^%ZTLOAD K ZTSK D HOME^%ZIS |
3292 | +"RTN","XTER1A",43,0) |
3293 | + ; |
3294 | +"RTN","XTER1A",44,0) |
3295 | +DQPRNT S XTPRNT=1,XTOUT=0 D WRT^XTER1 U IO D:C>0 WRITER |
3296 | +"RTN","XTER1A",45,0) |
3297 | + K ^TMP($J,"XTER"),XTX,XTPRNT S C=0 D ^%ZISC I $D(ZTQUEUED) Q |
3298 | +"RTN","XTER1A",46,0) |
3299 | + G XTERR^XTER |
3300 | +"RTN","XTER1A",47,0) |
3301 | + ; |
3302 | +"RTN","XTER1A",48,0) |
3303 | +WRITER F %=0:0 S %=$O(^TMP($J,"XTER",%)) Q:%'>0 W:((IOSL-$Y)'>4&$G(XTPRNT)) @IOF S %1=$S($D(^(%))=1:^(%),1:^(%,0)) D |
3304 | +"RTN","XTER1A",49,0) |
3305 | + .I $E(%1,1,6)="|PAGE|" W @IOF S %1=$E(%1,7,$L(%1)) Q:%1="" |
3306 | +"RTN","XTER1A",50,0) |
3307 | + .I $E(%1,1,4)="@IOF" W @IOF S %1=$E(%1,5,$L(%1)) Q:%1="" |
3308 | +"RTN","XTER1A",51,0) |
3309 | + .W !,%1 |
3310 | +"RTN","XTER1A",52,0) |
3311 | + K %,%1 |
3312 | +"RTN","XTER1A",53,0) |
3313 | + Q |
3314 | +"RTN","XTER1A",54,0) |
3315 | +MESSG S XMY(DUZ)="",XMDUZ=.5 I '$D(ZTQUEUED) K XMY,XMDUZ |
3316 | +"RTN","XTER1A",55,0) |
3317 | + S XMTEXT="^TMP($J,""XTER"",",XMSUB="ERROR - "_$E(%XTZE,1,40) F Q:XMSUB'[U S XMSUB=$P(XMSUB,U)_"~U~"_$P(XMSUB,U,2,99) |
3318 | +"RTN","XTER1A",56,0) |
3319 | + D ^XMD K XMY,XMTEXT,XMSUB |
3320 | +"RTN","XTER1A",57,0) |
3321 | + Q |
3322 | +"RTN","XTER1A",58,0) |
3323 | + ; |
3324 | +"RTN","XTER1A",59,0) |
3325 | +MORE Q:$G(XTMES) N DIR,DTOUT,DIRUT,DUOUT |
3326 | +"RTN","XTER1A",60,0) |
3327 | + S XTOUT=0,XTX="" D WRITER K ^TMP($J,"XTER") S C=0 |
3328 | +"RTN","XTER1A",61,0) |
3329 | + I '$D(ZTQUEUED),'$G(XTPRNT),$G(IOST)["C-" D |
3330 | +"RTN","XTER1A",62,0) |
3331 | + . S:($D(X)#2) XTMORE=X S DIR(0)="FO^0:50",DIR("A")=" Enter '^' to quit listing, <RETURN> to continue..." |
3332 | +"RTN","XTER1A",63,0) |
3333 | + . D ^DIR K DIR S:$D(DTOUT) X="^" S XTX=X S:$D(XTMORE) X=XTMORE K XTMORE |
3334 | +"RTN","XTER1A",64,0) |
3335 | + I $D(XTX),$E(XTX)="^" S XTOUT=1 Q |
3336 | +"RTN","XTER1A",65,0) |
3337 | + I $G(XTPRNT) W @IOF |
3338 | +"RTN","XTER1A",66,0) |
3339 | + Q |
3340 | +"RTN","XTER1A",67,0) |
3341 | + ; |
3342 | +"RTN","XTER1A",68,0) |
3343 | +LST S X=" ",XTQ="" N XTXT,XBLNK S $P(XBLNK," ",80)=" " |
3344 | +"RTN","XTER1A",69,0) |
3345 | +T1 S X=$O(^%ZTER(1,%XTZDAT,1,X),-1) R XTQ:0 Q:XTQ'="" G T2:X'>0,T1:'($D(^(X,"ZE"))#2) S XTP=^("ZE"),XTS="" |
3346 | +"RTN","XTER1A",70,0) |
3347 | + F S XTS=$O(^TMP($J,"XTERSCR",XTS)) Q:XTS="" I XTP[XTS,XTD S XTD=XTD+1 G T1 |
3348 | +"RTN","XTER1A",71,0) |
3349 | + ; |
3350 | +"RTN","XTER1A",72,0) |
3351 | + I '(X#20) S %XTERRX=X D MORE Q:XTOUT Q:XTX>0 D T3 S X=%XTERRX |
3352 | +"RTN","XTER1A",73,0) |
3353 | + I ^%ZTER(1,%XTZDAT,1,X,"ZE")["," S %XTERR=$P($P(^("ZE"),",",4),"-",4),%XTERR=$P($P(^("ZE"),",",2),"-",3)_$S(%XTERR="":"",1:"(")_%XTERR_$S(%XTERR="":"",1:")") S XTXT=$J(X,3)_") "_"<"_%XTERR_">"_$P(^("ZE"),",",1)_" " |
3354 | +"RTN","XTER1A",74,0) |
3355 | + I ^%ZTER(1,%XTZDAT,1,X,"ZE")'["," S XTXT=$J(X,3)_") "_^("ZE") |
3356 | +"RTN","XTER1A",75,0) |
3357 | + S %XTZNUM=X,%="" I $D(^%ZTER(1,%XTZDAT,1,%XTZNUM,"H")) S %H=^("H") D YMD^%DTC S %=$P(%,".",2)_"000000",%=$E(%,1,2)_":"_$E(%,3,4)_":"_$E(%,5,6) |
3358 | +"RTN","XTER1A",76,0) |
3359 | + S X=%XTZNUM S XTXT=$S($L(XTXT)>34:XTXT,1:$E(XTXT_XBLNK,1,34))_% |
3360 | +"RTN","XTER1A",77,0) |
3361 | + I $D(^%ZTER(1,%XTZDAT,1,X,"J")) S XTXT=XTXT_" ["_$P($P(^("J"),U,4),",")_"]" ;_" "_$J($P(^("J"),U,5),7) |
3362 | +"RTN","XTER1A",78,0) |
3363 | + D IHSXQY0 ;***IHS |
3364 | +"RTN","XTER1A",79,0) |
3365 | + W !,$E(XTXT,1,79) |
3366 | +"RTN","XTER1A",80,0) |
3367 | +COMMENT I $D(^DD(3.0751,21400)) D ;**MSC/GFT |
3368 | +"RTN","XTER1A",81,0) |
3369 | + .N DIC,DIQ,DR,DA,Y,S,DK,D0,D1 |
3370 | +"RTN","XTER1A",82,0) |
3371 | + .S DIC="^%ZTER(1,"_%XTZDAT_",1,",DIQ(0)="A",DR=21400,DA=X,DA(1)=%XTZDAT |
3372 | +"RTN","XTER1A",83,0) |
3373 | + .I $D(@(DIC_DA_",21400)")) N X D EN^DIQ |
3374 | +"RTN","XTER1A",84,0) |
3375 | + G T1 |
3376 | +"RTN","XTER1A",85,0) |
3377 | +T2 I XTD W !! I XTD-1 W XTD-1," screened error",$S(XTD-1>1:"s",1:""),! |
3378 | +"RTN","XTER1A",86,0) |
3379 | + ;D MORE |
3380 | +"RTN","XTER1A",87,0) |
3381 | + Q |
3382 | +"RTN","XTER1A",88,0) |
3383 | +T3 W !!,?11,"$ZE",?41,"Time",?49,"UCI,VOL",?61,"$J",?69,"$I",! |
3384 | +"RTN","XTER1A",89,0) |
3385 | + Q |
3386 | +"RTN","XTER1A",90,0) |
3387 | +INTRACT ; |
3388 | +"RTN","XTER1A",91,0) |
3389 | + G INTRACT^XTER1A1 |
3390 | +"RTN","XTER1A",92,0) |
3391 | + ; |
3392 | +"RTN","XTER1A",93,0) |
3393 | + ; |
3394 | +"RTN","XTER1A",94,0) |
3395 | + ; |
3396 | +"RTN","XTER1A",95,0) |
3397 | + ; |
3398 | +"RTN","XTER1A",96,0) |
3399 | +IHSXQY0 ;IHS/ANMC/LJF 5/20/99 find option name |
3400 | +"RTN","XTER1A",97,0) |
3401 | + NEW IHS,FOUND,STR |
3402 | +"RTN","XTER1A",98,0) |
3403 | + S (FOUND,IHS)=0,STR="" |
3404 | +"RTN","XTER1A",99,0) |
3405 | + F S IHS=$O(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS)) Q:'IHS Q:FOUND D |
3406 | +"RTN","XTER1A",100,0) |
3407 | + .I $G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,0))="DUZ" D Q |
3408 | +"RTN","XTER1A",101,0) |
3409 | + ..N D,Y S D=$G(^("D")) I D S Y=$P($G(^%ZTER(1,%XTZDAT,1,X,"J")),U,4),Y=$$UCICHECK^%ZOSV(Y) I $L(Y)>2 S STR=$P($G(^[$S(^%ZOSF("OS")["GT.M":$ZGB,1:Y)]VA(200,D,0)),",")_": " |
3410 | +"RTN","XTER1A",102,0) |
3411 | + . Q:$G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,0))'="XQY0" |
3412 | +"RTN","XTER1A",103,0) |
3413 | + . S STR=STR_$P($G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,"D")),U) |
3414 | +"RTN","XTER1A",104,0) |
3415 | + . S STR=$E(STR,1,26)_$$REPEAT^XLFSTR(" ",(26-$L(STR))),FOUND=1 |
3416 | +"RTN","XTER1A",105,0) |
3417 | + S XTXT=XTXT_" "_$G(STR) |
3418 | +"RTN","XTER1A",106,0) |
3419 | + Q |
3420 | +"RTN","XWBTCPM") |
3421 | +0^23^B56160723 |
3422 | +"RTN","XWBTCPM",1,0) |
3423 | +XWBTCPM ;ISF/RWF MSC/JDA - BROKER TCP/IP PROCESS HANDLER ;01/04/2006 62562.56228 |
3424 | +"RTN","XWBTCPM",2,0) |
3425 | + ;;1.1;RPC BROKER;**35,43,MSC**;Mar 28, 1997 |
3426 | +"RTN","XWBTCPM",3,0) |
3427 | + ;Based on: XWBTCPC & XWBTCPL, Modified by ISF/RWF |
3428 | +"RTN","XWBTCPM",4,0) |
3429 | + ;Changed to be started by UCX or %ZISTCPS |
3430 | +"RTN","XWBTCPM",5,0) |
3431 | + ; |
3432 | +"RTN","XWBTCPM",6,0) |
3433 | + ;MSC/JDA 04/13/09 - Added MOREREADTIME to GT.M init |
3434 | +"RTN","XWBTCPM",7,0) |
3435 | + ; |
3436 | +"RTN","XWBTCPM",8,0) |
3437 | +DSM ;DSM called from ucx, % passed in with device. |
3438 | +"RTN","XWBTCPM",9,0) |
3439 | + D ESET |
3440 | +"RTN","XWBTCPM",10,0) |
3441 | + ;Open the device |
3442 | +"RTN","XWBTCPM",11,0) |
3443 | + S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open |
3444 | +"RTN","XWBTCPM",12,0) |
3445 | + ;Go find the connection type |
3446 | +"RTN","XWBTCPM",13,0) |
3447 | + U XWBTDEV |
3448 | +"RTN","XWBTCPM",14,0) |
3449 | + G CONNTYPE |
3450 | +"RTN","XWBTCPM",15,0) |
3451 | + ; |
3452 | +"RTN","XWBTCPM",16,0) |
3453 | +CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file |
3454 | +"RTN","XWBTCPM",17,0) |
3455 | + D ESET |
3456 | +"RTN","XWBTCPM",18,0) |
3457 | + S XWBTDEV="SYS$NET" |
3458 | +"RTN","XWBTCPM",19,0) |
3459 | + ; **Cache'/VMS specific code** |
3460 | +"RTN","XWBTCPM",20,0) |
3461 | + O XWBTDEV::5 |
3462 | +"RTN","XWBTCPM",21,0) |
3463 | + X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM |
3464 | +"RTN","XWBTCPM",22,0) |
3465 | + G CONNTYPE |
3466 | +"RTN","XWBTCPM",23,0) |
3467 | + ; |
3468 | +"RTN","XWBTCPM",24,0) |
3469 | +NT ;entry from ZISTCPS |
3470 | +"RTN","XWBTCPM",25,0) |
3471 | + ;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code") |
3472 | +"RTN","XWBTCPM",26,0) |
3473 | + D ESET |
3474 | +"RTN","XWBTCPM",27,0) |
3475 | + S XWBTDEV=IO |
3476 | +"RTN","XWBTCPM",28,0) |
3477 | + G CONNTYPE |
3478 | +"RTN","XWBTCPM",29,0) |
3479 | + ; |
3480 | +"RTN","XWBTCPM",30,0) |
3481 | +GTMUCX(%) ;From ucx ZFOO |
3482 | +"RTN","XWBTCPM",31,0) |
3483 | + ;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO |
3484 | +"RTN","XWBTCPM",32,0) |
3485 | + D ESET |
3486 | +"RTN","XWBTCPM",33,0) |
3487 | + ;GTM specific code |
3488 | +"RTN","XWBTCPM",34,0) |
3489 | + S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""") |
3490 | +"RTN","XWBTCPM",35,0) |
3491 | + S XWBTDEV=% X "O %:(RECORDSIZE=512)" |
3492 | +"RTN","XWBTCPM",36,0) |
3493 | + G CONNTYPE |
3494 | +"RTN","XWBTCPM",37,0) |
3495 | + ; |
3496 | +"RTN","XWBTCPM",38,0) |
3497 | +GTMLNX ;From Linux xinetd script |
3498 | +"RTN","XWBTCPM",39,0) |
3499 | + D ESET |
3500 | +"RTN","XWBTCPM",40,0) |
3501 | + ;GTM specific code |
3502 | +"RTN","XWBTCPM",41,0) |
3503 | + S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""") |
3504 | +"RTN","XWBTCPM",42,0) |
3505 | + S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter)" |
3506 | +"RTN","XWBTCPM",43,0) |
3507 | + S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=% |
3508 | +"RTN","XWBTCPM",44,0) |
3509 | + G CONNTYPE |
3510 | +"RTN","XWBTCPM",45,0) |
3511 | + ; |
3512 | +"RTN","XWBTCPM",46,0) |
3513 | +ESET ;Set inital error trap |
3514 | +"RTN","XWBTCPM",47,0) |
3515 | + S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap |
3516 | +"RTN","XWBTCPM",48,0) |
3517 | + Q |
3518 | +"RTN","XWBTCPM",49,0) |
3519 | + ;Find the type of connection and jump to the processing routine. |
3520 | +"RTN","XWBTCPM",50,0) |
3521 | +CONNTYPE ; |
3522 | +"RTN","XWBTCPM",51,0) |
3523 | + N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE |
3524 | +"RTN","XWBTCPM",52,0) |
3525 | + N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT |
3526 | +"RTN","XWBTCPM",53,0) |
3527 | + N SOCK,TYPE |
3528 | +"RTN","XWBTCPM",54,0) |
3529 | + D INIT |
3530 | +"RTN","XWBTCPM",55,0) |
3531 | + S XWB=$$BREAD^XWBRW(5,XWBTIME) |
3532 | +"RTN","XWBTCPM",56,0) |
3533 | + D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",1:"Unk")) |
3534 | +"RTN","XWBTCPM",57,0) |
3535 | + I XWB["[XWB]" G NEW |
3536 | +"RTN","XWBTCPM",58,0) |
3537 | + I XWB["{XWB}" G OLD^XWBTCPM1 |
3538 | +"RTN","XWBTCPM",59,0) |
3539 | + I XWB["<?xml" G M2M |
3540 | +"RTN","XWBTCPM",60,0) |
3541 | + I $L($T(OTH^XWBTCPM2)) D OTH^XWBTCPM2 ;See if a special code. |
3542 | +"RTN","XWBTCPM",61,0) |
3543 | + D LOG("Prefix not known: "_XWB) |
3544 | +"RTN","XWBTCPM",62,0) |
3545 | + Q |
3546 | +"RTN","XWBTCPM",63,0) |
3547 | + ; |
3548 | +"RTN","XWBTCPM",64,0) |
3549 | +NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK. |
3550 | +"RTN","XWBTCPM",65,0) |
3551 | + N X,Y,J,XWBVOL |
3552 | +"RTN","XWBTCPM",66,0) |
3553 | + D GETENV^%ZOSV S XWBVOL=$P(Y,"^",2) |
3554 | +"RTN","XWBTCPM",67,0) |
3555 | + S X=$O(^XTV(8989.3,1,4,"B",XWBVOL,0)),J=$S(X>0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1") |
3556 | +"RTN","XWBTCPM",68,0) |
3557 | + I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS? |
3558 | +"RTN","XWBTCPM",69,0) |
3559 | + I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0 |
3560 | +"RTN","XWBTCPM",70,0) |
3561 | + Q 1 |
3562 | +"RTN","XWBTCPM",71,0) |
3563 | + ; |
3564 | +"RTN","XWBTCPM",72,0) |
3565 | +M2M ;M2M Broker |
3566 | +"RTN","XWBTCPM",73,0) |
3567 | + S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL |
3568 | +"RTN","XWBTCPM",74,0) |
3569 | + Q |
3570 | +"RTN","XWBTCPM",75,0) |
3571 | + ; |
3572 | +"RTN","XWBTCPM",76,0) |
3573 | +NEW ;New broker |
3574 | +"RTN","XWBTCPM",77,0) |
3575 | + S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108 |
3576 | +"RTN","XWBTCPM",78,0) |
3577 | + D SETTIME(1) ;Setup for sign-on timeout |
3578 | +"RTN","XWBTCPM",79,0) |
3579 | + U XWBTDEV D |
3580 | +"RTN","XWBTCPM",80,0) |
3581 | + . N XWB,ERR,NATIP,I |
3582 | +"RTN","XWBTCPM",81,0) |
3583 | + . S ERR=$$PRSP^XWBPRS |
3584 | +"RTN","XWBTCPM",82,0) |
3585 | + . S ERR=$$PRSM^XWBPRS |
3586 | +"RTN","XWBTCPM",83,0) |
3587 | + . S MSG=$G(XWB(4,"CMD")) ;Build connect msg. |
3588 | +"RTN","XWBTCPM",84,0) |
3589 | + . S I="" F S I=$O(XWB(5,"P",I)) Q:I="" S MSG=MSG_U_XWB(5,"P",I) |
3590 | +"RTN","XWBTCPM",85,0) |
3591 | + . ;Get the peer and save that IP. |
3592 | +"RTN","XWBTCPM",86,0) |
3593 | + . S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2) |
3594 | +"RTN","XWBTCPM",87,0) |
3595 | + . I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP |
3596 | +"RTN","XWBTCPM",88,0) |
3597 | + . Q |
3598 | +"RTN","XWBTCPM",89,0) |
3599 | + S X=$$NEWJOB() D:'X LOG("No New Connects") |
3600 | +"RTN","XWBTCPM",90,0) |
3601 | + I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q |
3602 | +"RTN","XWBTCPM",91,0) |
3603 | + D QSND^XWBRW("accept"),LOG("accept") ;Ack |
3604 | +"RTN","XWBTCPM",92,0) |
3605 | + S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4) |
3606 | +"RTN","XWBTCPM",93,0) |
3607 | + S XWBTIP=$G(IO("IP")) |
3608 | +"RTN","XWBTCPM",94,0) |
3609 | + ;start RUM for Broker Handler XWB*1.1*5 |
3610 | +"RTN","XWBTCPM",95,0) |
3611 | + D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1) |
3612 | +"RTN","XWBTCPM",96,0) |
3613 | + ;GTM |
3614 | +"RTN","XWBTCPM",97,0) |
3615 | + I $G(XWBT("PCNT")) D |
3616 | +"RTN","XWBTCPM",98,0) |
3617 | + . S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0 |
3618 | +"RTN","XWBTCPM",99,0) |
3619 | + . D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X) |
3620 | +"RTN","XWBTCPM",100,0) |
3621 | + ;We don't use a callback |
3622 | +"RTN","XWBTCPM",101,0) |
3623 | + K XWB,CON,LEN,MSG ;Clean up |
3624 | +"RTN","XWBTCPM",102,0) |
3625 | + ;Attempt to share license, Must have TCP port open first. |
3626 | +"RTN","XWBTCPM",103,0) |
3627 | + U XWBTDEV ;D SHARELIC^%ZOSV(1) |
3628 | +"RTN","XWBTCPM",104,0) |
3629 | + ;setup null device "NULL" |
3630 | +"RTN","XWBTCPM",105,0) |
3631 | + S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D ^%ZTER,EXIT Q |
3632 | +"RTN","XWBTCPM",106,0) |
3633 | + D SAVDEV^%ZISUTL("XWBNULL") |
3634 | +"RTN","XWBTCPM",107,0) |
3635 | + ;change process name |
3636 | +"RTN","XWBTCPM",108,0) |
3637 | + D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV) |
3638 | +"RTN","XWBTCPM",109,0) |
3639 | + ; |
3640 | +"RTN","XWBTCPM",110,0) |
3641 | +RESTART ;The error trap returns to here |
3642 | +"RTN","XWBTCPM",111,0) |
3643 | + N $ESTACK S $ETRAP="D ETRAP^XWBTCPM" |
3644 | +"RTN","XWBTCPM",112,0) |
3645 | + S DT=$$DT^XLFDT,DTIME=30 |
3646 | +"RTN","XWBTCPM",113,0) |
3647 | + U XWBTDEV D MAIN |
3648 | +"RTN","XWBTCPM",114,0) |
3649 | + D LOG("Exit: "_XWBTBUF) |
3650 | +"RTN","XWBTCPM",115,0) |
3651 | + ;Turn off the error trap for the exit |
3652 | +"RTN","XWBTCPM",116,0) |
3653 | + S $ETRAP="" |
3654 | +"RTN","XWBTCPM",117,0) |
3655 | + D EXIT ;Logout |
3656 | +"RTN","XWBTCPM",118,0) |
3657 | + K XWBR,XWBARY |
3658 | +"RTN","XWBTCPM",119,0) |
3659 | + ;stop RUM for handler XWB*1.1*5 |
3660 | +"RTN","XWBTCPM",120,0) |
3661 | + D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2) |
3662 | +"RTN","XWBTCPM",121,0) |
3663 | + D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL") |
3664 | +"RTN","XWBTCPM",122,0) |
3665 | + ;Close in the calling script |
3666 | +"RTN","XWBTCPM",123,0) |
3667 | + K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF |
3668 | +"RTN","XWBTCPM",124,0) |
3669 | + Q |
3670 | +"RTN","XWBTCPM",125,0) |
3671 | + ; |
3672 | +"RTN","XWBTCPM",126,0) |
3673 | +MAIN ; -- main message processing loop. debug at MAIN+1 |
3674 | +"RTN","XWBTCPM",127,0) |
3675 | + F D Q:XWBTBUF="#BYE#" |
3676 | +"RTN","XWBTCPM",128,0) |
3677 | + . ;Setup |
3678 | +"RTN","XWBTCPM",129,0) |
3679 | + . S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF="" |
3680 | +"RTN","XWBTCPM",130,0) |
3681 | + . K XWBR,XWBARY,XWBPRT |
3682 | +"RTN","XWBTCPM",131,0) |
3683 | + . ; -- read client request |
3684 | +"RTN","XWBTCPM",132,0) |
3685 | + . S XR=$$BREAD^XWBRW(1,XWBTIME,1) |
3686 | +"RTN","XWBTCPM",133,0) |
3687 | + . I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q |
3688 | +"RTN","XWBTCPM",134,0) |
3689 | + . S XR=XR_$$BREAD^XWBRW(4) |
3690 | +"RTN","XWBTCPM",135,0) |
3691 | + . I XR="#BYE#" D Q ;Check for exit |
3692 | +"RTN","XWBTCPM",136,0) |
3693 | + . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#" |
3694 | +"RTN","XWBTCPM",137,0) |
3695 | + . . Q |
3696 | +"RTN","XWBTCPM",138,0) |
3697 | + . S TYPE=(XR="[XWB]") ;check HDR |
3698 | +"RTN","XWBTCPM",139,0) |
3699 | + . I 'TYPE D LOG("Bad Header: "_XR) Q |
3700 | +"RTN","XWBTCPM",140,0) |
3701 | + . D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC |
3702 | +"RTN","XWBTCPM",141,0) |
3703 | + . IF XWBTCMD="#BYE#" D Q |
3704 | +"RTN","XWBTCPM",142,0) |
3705 | + . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD |
3706 | +"RTN","XWBTCPM",143,0) |
3707 | + . . Q |
3708 | +"RTN","XWBTCPM",144,0) |
3709 | + . U XWBTDEV |
3710 | +"RTN","XWBTCPM",145,0) |
3711 | + . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE) |
3712 | +"RTN","XWBTCPM",146,0) |
3713 | + . ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return |
3714 | +"RTN","XWBTCPM",147,0) |
3715 | + . I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer |
3716 | +"RTN","XWBTCPM",148,0) |
3717 | + Q ;End Of Main |
3718 | +"RTN","XWBTCPM",149,0) |
3719 | + ; |
3720 | +"RTN","XWBTCPM",150,0) |
3721 | + ; |
3722 | +"RTN","XWBTCPM",151,0) |
3723 | +ETRAP ; -- on trapped error, send error info to client |
3724 | +"RTN","XWBTCPM",152,0) |
3725 | + N XWBERC,XWBERR |
3726 | +"RTN","XWBTCPM",153,0) |
3727 | + ;Change trapping during trap. |
3728 | +"RTN","XWBTCPM",154,0) |
3729 | + S $ETRAP="D ^%ZTER,EXIT^XWBTCPM HALT" |
3730 | +"RTN","XWBTCPM",155,0) |
3731 | + S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV |
3732 | +"RTN","XWBTCPM",156,0) |
3733 | + I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server" |
3734 | +"RTN","XWBTCPM",157,0) |
3735 | + D ^%ZTER ;%ZTER clears $ZE and $ZCODE |
3736 | +"RTN","XWBTCPM",158,0) |
3737 | + D LOG("In ETRAP: "_XWBERC) ;Log |
3738 | +"RTN","XWBTCPM",159,0) |
3739 | + I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F") D EXIT HALT |
3740 | +"RTN","XWBTCPM",160,0) |
3741 | + U XWBTDEV |
3742 | +"RTN","XWBTCPM",161,0) |
3743 | + I $G(XWBT("PCNT")) L ^XUTL("XUSYS",$J,0) |
3744 | +"RTN","XWBTCPM",162,0) |
3745 | + E L ;Clear Locks |
3746 | +"RTN","XWBTCPM",163,0) |
3747 | + ;I XWBOS'="DSM" D |
3748 | +"RTN","XWBTCPM",164,0) |
3749 | + S XWBPTYPE=1 ;So SNDERR won't check XWBR |
3750 | +"RTN","XWBTCPM",165,0) |
3751 | + ;D SNDERR^XWBRW,WRITE^XWBRW($C(24)_XWBERR_$C(4)) |
3752 | +"RTN","XWBTCPM",166,0) |
3753 | + D ESND^XWBRW($C(24)_XWBERR_$C(4)) |
3754 | +"RTN","XWBTCPM",167,0) |
3755 | + S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99," |
3756 | +"RTN","XWBTCPM",168,0) |
3757 | + Q |
3758 | +"RTN","XWBTCPM",169,0) |
3759 | + ; |
3760 | +"RTN","XWBTCPM",170,0) |
3761 | +CLEANP ;Clean up the partion |
3762 | +"RTN","XWBTCPM",171,0) |
3763 | + N XWBTDEV,XWBNULL D KILL^XUSCLEAN |
3764 | +"RTN","XWBTCPM",172,0) |
3765 | + Q |
3766 | +"RTN","XWBTCPM",173,0) |
3767 | + ; |
3768 | +"RTN","XWBTCPM",174,0) |
3769 | +STYPE(X,WRAP) ;For backward compatability only |
3770 | +"RTN","XWBTCPM",175,0) |
3771 | + I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP) |
3772 | +"RTN","XWBTCPM",176,0) |
3773 | + Q $$RTRNFMT^XWBLIB(X) |
3774 | +"RTN","XWBTCPM",177,0) |
3775 | + ; |
3776 | +"RTN","XWBTCPM",178,0) |
3777 | +BREAD(L,T) ;read tcp buffer, L is length |
3778 | +"RTN","XWBTCPM",179,0) |
3779 | + Q $$BREAD^XWBRW(L,$G(T)) |
3780 | +"RTN","XWBTCPM",180,0) |
3781 | + ; |
3782 | +"RTN","XWBTCPM",181,0) |
3783 | +CHPRN(N) ;change process name |
3784 | +"RTN","XWBTCPM",182,0) |
3785 | + ;Change process name to N |
3786 | +"RTN","XWBTCPM",183,0) |
3787 | + D SETNM^%ZOSV($E(N,1,15)) |
3788 | +"RTN","XWBTCPM",184,0) |
3789 | + Q |
3790 | +"RTN","XWBTCPM",185,0) |
3791 | + ; |
3792 | +"RTN","XWBTCPM",186,0) |
3793 | +SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on |
3794 | +"RTN","XWBTCPM",187,0) |
3795 | + S XWBTIME=$S($G(%):90,$G(XWBVER)>1.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=2 |
3796 | +"RTN","XWBTCPM",188,0) |
3797 | + I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000) |
3798 | +"RTN","XWBTCPM",189,0) |
3799 | + Q |
3800 | +"RTN","XWBTCPM",190,0) |
3801 | +TIMEOUT ;Do this on MAIN loop timeout |
3802 | +"RTN","XWBTCPM",191,0) |
3803 | + I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q |
3804 | +"RTN","XWBTCPM",192,0) |
3805 | + ;Sign-on timeout |
3806 | +"RTN","XWBTCPM",193,0) |
3807 | + S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2 |
3808 | +"RTN","XWBTCPM",194,0) |
3809 | + D SND^XWBRW |
3810 | +"RTN","XWBTCPM",195,0) |
3811 | + Q |
3812 | +"RTN","XWBTCPM",196,0) |
3813 | + ; |
3814 | +"RTN","XWBTCPM",197,0) |
3815 | +OS() ;Return the OS |
3816 | +"RTN","XWBTCPM",198,0) |
3817 | + Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",^("OS")["GT.M":"GTM",1:"MSM") |
3818 | +"RTN","XWBTCPM",199,0) |
3819 | + ; |
3820 | +"RTN","XWBTCPM",200,0) |
3821 | +INIT ;Setup |
3822 | +"RTN","XWBTCPM",201,0) |
3823 | + S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF="" |
3824 | +"RTN","XWBTCPM",202,0) |
3825 | + S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG") |
3826 | +"RTN","XWBTCPM",203,0) |
3827 | + S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!") |
3828 | +"RTN","XWBTCPM",204,0) |
3829 | + X:$D(XWBTDEV)&(XWBOS="GTM") "U XWBTDEV:(MOREREADTIME=999)" |
3830 | +"RTN","XWBTCPM",205,0) |
3831 | + S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1 |
3832 | +"RTN","XWBTCPM",206,0) |
3833 | + D LOGSTART^XWBDLOG("XWBTCPM") |
3834 | +"RTN","XWBTCPM",207,0) |
3835 | + Q |
3836 | +"RTN","XWBTCPM",208,0) |
3837 | + ; |
3838 | +"RTN","XWBTCPM",209,0) |
3839 | +DEBUG ;Entry point for debug, Build a server to get the connect |
3840 | +"RTN","XWBTCPM",210,0) |
3841 | + ;DSM sample;ZDEBUG ON S $ZB(1)="SERV+1^XWBTCPM:1",$ZB="ETRAP+1^XWBTCPM:1" |
3842 | +"RTN","XWBTCPM",211,0) |
3843 | + W !,"Before running this entry point set your debugger to stop at" |
3844 | +"RTN","XWBTCPM",212,0) |
3845 | + W !,"the place you want to debug. Some spots to use:" |
3846 | +"RTN","XWBTCPM",213,0) |
3847 | + W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",! |
3848 | +"RTN","XWBTCPM",214,0) |
3849 | + W !,"or location of your choice.",! |
3850 | +"RTN","XWBTCPM",215,0) |
3851 | + W !,"IP Socket to Listen on: " R SOCK:300 Q:'$T!(SOCK["^") |
3852 | +"RTN","XWBTCPM",216,0) |
3853 | + ;Use %ZISTCP to do a single server |
3854 | +"RTN","XWBTCPM",217,0) |
3855 | + D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM") |
3856 | +"RTN","XWBTCPM",218,0) |
3857 | + U $P W !,"Done" |
3858 | +"RTN","XWBTCPM",219,0) |
3859 | + Q |
3860 | +"RTN","XWBTCPM",220,0) |
3861 | +SERV ;Callback from the server |
3862 | +"RTN","XWBTCPM",221,0) |
3863 | + S XWBTDEV=IO,XWBTIME(1)=3600 D INIT |
3864 | +"RTN","XWBTCPM",222,0) |
3865 | + S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5 |
3866 | +"RTN","XWBTCPM",223,0) |
3867 | + D NEW |
3868 | +"RTN","XWBTCPM",224,0) |
3869 | + S IO("C")=1 ;Cause the Listenr to stop |
3870 | +"RTN","XWBTCPM",225,0) |
3871 | + Q |
3872 | +"RTN","XWBTCPM",226,0) |
3873 | + ; |
3874 | +"RTN","XWBTCPM",227,0) |
3875 | +EXIT ;Close out |
3876 | +"RTN","XWBTCPM",228,0) |
3877 | + I $G(DUZ) D LOGOUT^XUSRB |
3878 | +"RTN","XWBTCPM",229,0) |
3879 | + I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1) |
3880 | +"RTN","XWBTCPM",230,0) |
3881 | + Q |
3882 | +"RTN","XWBTCPM",231,0) |
3883 | + ; |
3884 | +"RTN","XWBTCPM",232,0) |
3885 | +LOG(MSG) ;Record Debug Info |
3886 | +"RTN","XWBTCPM",233,0) |
3887 | + D:$G(XWBDEBUG) LOG^XWBDLOG(MSG) |
3888 | +"RTN","XWBTCPM",234,0) |
3889 | + Q |
3890 | +"RTN","XWBTCPM",235,0) |
3891 | + ; |
3892 | +"RTN","ZCD") |
3893 | +0^11^B5581 |
3894 | +"RTN","ZCD",1,0) |
3895 | +ZCD ; MSC/JKT ; "Namespace" utilities for GT.M/Unix ; 01/30/2009 |
3896 | +"RTN","ZCD",2,0) |
3897 | + ; |
3898 | +"RTN","ZCD",3,0) |
3899 | + ; This routine assumes that your global directory file exists one |
3900 | +"RTN","ZCD",4,0) |
3901 | + ; directory below the root of the instance, e.g., |
3902 | +"RTN","ZCD",5,0) |
3903 | + ; |
3904 | +"RTN","ZCD",6,0) |
3905 | + ; /opt/openvista/instance/globals/mumps.gld |
3906 | +"RTN","ZCD",7,0) |
3907 | + ; |
3908 | +"RTN","ZCD",8,0) |
3909 | + ; or |
3910 | +"RTN","ZCD",9,0) |
3911 | + ; |
3912 | +"RTN","ZCD",10,0) |
3913 | + ; /home/vista/instance/g/default.gld |
3914 | +"RTN","ZCD",11,0) |
3915 | + ; |
3916 | +"RTN","ZCD",12,0) |
3917 | + ; The actual file name of the global directory file and the actual name |
3918 | +"RTN","ZCD",13,0) |
3919 | + ; of the parent directory are never checked, so their names do not |
3920 | +"RTN","ZCD",14,0) |
3921 | + ; matter. |
3922 | +"RTN","ZCD",15,0) |
3923 | + G CD |
3924 | +"RTN","ZCD",16,0) |
3925 | + ; |
3926 | +"RTN","ZCD",17,0) |
3927 | +CURRENT() |
3928 | +"RTN","ZCD",18,0) |
3929 | + ; return the name of the current OpenVista instance |
3930 | +"RTN","ZCD",19,0) |
3931 | + Q $P($ZG,"/",$L($ZG,"/")-2) |
3932 | +"RTN","ZCD",20,0) |
3933 | + ; |
3934 | +"RTN","ZCD",21,0) |
3935 | +PATH() |
3936 | +"RTN","ZCD",22,0) |
3937 | + ; return the path to the current OpenVista instance |
3938 | +"RTN","ZCD",23,0) |
3939 | + N I,X S X="" |
3940 | +"RTN","ZCD",24,0) |
3941 | + S X=$P($ZG,"/",1,$L($ZG,"/")-2) |
3942 | +"RTN","ZCD",25,0) |
3943 | + Q X |
3944 | +"RTN","ZCD",26,0) |
3945 | + ; |
3946 | +"RTN","ZCD",27,0) |
3947 | +ROOT() |
3948 | +"RTN","ZCD",28,0) |
3949 | + ; return the path where all OpenVista instances live |
3950 | +"RTN","ZCD",29,0) |
3951 | + N I,X S X="" |
3952 | +"RTN","ZCD",30,0) |
3953 | + S X=$P($ZG,"/",1,$L($ZG,"/")-3) |
3954 | +"RTN","ZCD",31,0) |
3955 | + Q X |
3956 | +"RTN","ZCD",32,0) |
3957 | + ; |
3958 | +"RTN","ZCD",33,0) |
3959 | +LIST() |
3960 | +"RTN","ZCD",34,0) |
3961 | + ; returns an array (Y) of OpenVista instances on this system |
3962 | +"RTN","ZCD",35,0) |
3963 | + ; |
3964 | +"RTN","ZCD",36,0) |
3965 | + ; FIXME: a "user friendly" version of this list should screen out the |
3966 | +"RTN","ZCD",37,0) |
3967 | + ; current instance name and any instances that the current user |
3968 | +"RTN","ZCD",38,0) |
3969 | + ; should not be allowed to switch to (they must have access |
3970 | +"RTN","ZCD",39,0) |
3971 | + ; code and primary menu option in the target instance to switch) |
3972 | +"RTN","ZCD",40,0) |
3973 | + ; |
3974 | +"RTN","ZCD",41,0) |
3975 | + ; FIXME: this routine currently requires GT.M V5.3003 because it uses |
3976 | +"RTN","ZCD",42,0) |
3977 | + ; PIPE I/O. We many want to make it compatible with older |
3978 | +"RTN","ZCD",43,0) |
3979 | + ; versions of GT.M by falling back to using temporary files, |
3980 | +"RTN","ZCD",44,0) |
3981 | + ; but on versions of GT.M V5.3003 and later, we definitely want |
3982 | +"RTN","ZCD",45,0) |
3983 | + ; to use PIPEs to avoid temporary files moving forward. |
3984 | +"RTN","ZCD",46,0) |
3985 | + N P,I,X |
3986 | +"RTN","ZCD",47,0) |
3987 | + S P="ls" |
3988 | +"RTN","ZCD",48,0) |
3989 | + O P:(COMMAND="ls --color=none -1 "_$$ROOT():READONLY)::"PIPE" |
3990 | +"RTN","ZCD",49,0) |
3991 | + U P |
3992 | +"RTN","ZCD",50,0) |
3993 | + F I=1:1 R X Q:X="" S Y(I)=X,Y("B",X)="" |
3994 | +"RTN","ZCD",51,0) |
3995 | + U $P |
3996 | +"RTN","ZCD",52,0) |
3997 | + C P |
3998 | +"RTN","ZCD",53,0) |
3999 | + Q |
4000 | +"RTN","ZCD",54,0) |
4001 | + ; |
4002 | +"RTN","ZCD",55,0) |
4003 | +GTMPATH(INSTANCE) |
4004 | +"RTN","ZCD",56,0) |
4005 | + ; return the path to the version of GT.M this instance uses |
4006 | +"RTN","ZCD",57,0) |
4007 | + ; |
4008 | +"RTN","ZCD",58,0) |
4009 | + ; FIXME: handle the case when INSTANCE is bogus |
4010 | +"RTN","ZCD",59,0) |
4011 | + ; |
4012 | +"RTN","ZCD",60,0) |
4013 | + N P,X |
4014 | +"RTN","ZCD",61,0) |
4015 | + S P="readlink" |
4016 | +"RTN","ZCD",62,0) |
4017 | + O P:(COMMAND="readlink "_$$ROOT()_"/"_INSTANCE_"/gtm":READONLY)::"PIPE" |
4018 | +"RTN","ZCD",63,0) |
4019 | + U P |
4020 | +"RTN","ZCD",64,0) |
4021 | + R X |
4022 | +"RTN","ZCD",65,0) |
4023 | + U $P |
4024 | +"RTN","ZCD",66,0) |
4025 | + C P |
4026 | +"RTN","ZCD",67,0) |
4027 | + Q X |
4028 | +"RTN","ZCD",68,0) |
4029 | + ; |
4030 | +"RTN","ZCD",69,0) |
4031 | +SWITCH(INSTANCE) |
4032 | +"RTN","ZCD",70,0) |
4033 | + ; switch to another OpenVista instance by setting $ZG and $ZRO |
4034 | +"RTN","ZCD",71,0) |
4035 | + ; |
4036 | +"RTN","ZCD",72,0) |
4037 | + ; there are several ways to do this; try them in order until |
4038 | +"RTN","ZCD",73,0) |
4039 | + ; one succeeds |
4040 | +"RTN","ZCD",74,0) |
4041 | + ; |
4042 | +"RTN","ZCD",75,0) |
4043 | + ; FIXME: we may want to allow this entry point to be called using DO |
4044 | +"RTN","ZCD",76,0) |
4045 | + Q:$$SWITCH1(INSTANCE) 1 |
4046 | +"RTN","ZCD",77,0) |
4047 | + Q:$$SWITCH2(INSTANCE) 1 |
4048 | +"RTN","ZCD",78,0) |
4049 | + Q:$$SWITCH3(INSTANCE) 1 |
4050 | +"RTN","ZCD",79,0) |
4051 | + Q 0 |
4052 | +"RTN","ZCD",80,0) |
4053 | + ; |
4054 | +"RTN","ZCD",81,0) |
4055 | +SWITCH1(INSTANCE) |
4056 | +"RTN","ZCD",82,0) |
4057 | + ; private entry point |
4058 | +"RTN","ZCD",83,0) |
4059 | + ; |
4060 | +"RTN","ZCD",84,0) |
4061 | + ; look for new values of $ZG and $ZRO in env directory of |
4062 | +"RTN","ZCD",85,0) |
4063 | + ; target instance |
4064 | +"RTN","ZCD",86,0) |
4065 | + N ZG,ZRO,G,RO |
4066 | +"RTN","ZCD",87,0) |
4067 | + ; |
4068 | +"RTN","ZCD",88,0) |
4069 | + ; FIXME: if file does not exist or is unreadable (permission |
4070 | +"RTN","ZCD",89,0) |
4071 | + ; denied), Q 0 |
4072 | +"RTN","ZCD",90,0) |
4073 | + ;S G=$$ROOT()_"/"_INSTANCE_"/env/gtmgbldir" |
4074 | +"RTN","ZCD",91,0) |
4075 | + ;O G:READONLY U G R ZG U $P C G |
4076 | +"RTN","ZCD",92,0) |
4077 | + N I,A S A="/"_$$CURRENT()_"/",ZG="" |
4078 | +"RTN","ZCD",93,0) |
4079 | + F I=1:1:$L($ZG,A) S ZG=ZG_$P($ZG,A,I)_$S(I=$L($ZG,A):"",1:"/"_INSTANCE_"/") |
4080 | +"RTN","ZCD",94,0) |
4081 | + ; |
4082 | +"RTN","ZCD",95,0) |
4083 | + ; FIXME: if file does not exist or is unreadable (permission |
4084 | +"RTN","ZCD",96,0) |
4085 | + ; denied), Q 0 |
4086 | +"RTN","ZCD",97,0) |
4087 | + ;S RO=$$ROOT()_"/"_INSTANCE_"/env/gtmroutines" |
4088 | +"RTN","ZCD",98,0) |
4089 | + ;O RO:READONLY U RO R ZRO U $P C RO |
4090 | +"RTN","ZCD",99,0) |
4091 | + S ZRO="" |
4092 | +"RTN","ZCD",100,0) |
4093 | + F I=1:1:$L($ZRO,A) S ZRO=ZRO_$P($ZRO,A,I)_$S(I=$L($ZRO,A):"",1:"/"_INSTANCE_"/") |
4094 | +"RTN","ZCD",101,0) |
4095 | + ; |
4096 | +"RTN","ZCD",102,0) |
4097 | + S $ZG=ZG,$ZRO=ZRO |
4098 | +"RTN","ZCD",103,0) |
4099 | + ; |
4100 | +"RTN","ZCD",104,0) |
4101 | + ;zlink the buffer |
4102 | +"RTN","ZCD",105,0) |
4103 | + X "Q" |
4104 | +"RTN","ZCD",106,0) |
4105 | + N I |
4106 | +"RTN","ZCD",107,0) |
4107 | + S I=$view("rtnnext","") |
4108 | +"RTN","ZCD",108,0) |
4109 | +NEXT F S I=$VIEW("rtnnext",I) Q:I="" I I'="GTM$DMOD" D |
4110 | +"RTN","ZCD",109,0) |
4111 | + .I I="ZCD" Q |
4112 | +"RTN","ZCD",110,0) |
4113 | + .I $E(I)="%" Q:($E(I,2)'="Z") |
4114 | +"RTN","ZCD",111,0) |
4115 | + .K %ZR S A=$TR(I,"%","_") D SILENT^%RSEL(A) I $D(%ZR(A)) N $ET S $ET="G NEXT^ZCD" ZLINK A_".m" Q |
4116 | +"RTN","ZCD",112,0) |
4117 | + .N DIE,X,B S X=I,B(1,0)=I_" ;",B(2,0)=" ZMESSAGE 150374338:$PIECE($ZPOSITION,""^"",2)",B(3,0)=" QUIT" |
4118 | +"RTN","ZCD",113,0) |
4119 | + .S DIE="B(",XCN=0 N I D SAVE(X) |
4120 | +"RTN","ZCD",114,0) |
4121 | + ; FIXME: do we need to set $ZINTERRUPT and $PATH? |
4122 | +"RTN","ZCD",115,0) |
4123 | + Q 1 |
4124 | +"RTN","ZCD",116,0) |
4125 | + ; |
4126 | +"RTN","ZCD",117,0) |
4127 | +SWITCH2(INSTANCE) |
4128 | +"RTN","ZCD",118,0) |
4129 | + ; private entry point |
4130 | +"RTN","ZCD",119,0) |
4131 | + ; |
4132 | +"RTN","ZCD",120,0) |
4133 | + ; look for new values of $ZG and $ZRO in env file of target instance |
4134 | +"RTN","ZCD",121,0) |
4135 | + ; |
4136 | +"RTN","ZCD",122,0) |
4137 | + ; if the env file does not exist or is unreadable (permission denied) |
4138 | +"RTN","ZCD",123,0) |
4139 | + ; or unparsable, Q 0 without setting $ZG and $ZRO |
4140 | +"RTN","ZCD",124,0) |
4141 | + ; |
4142 | +"RTN","ZCD",125,0) |
4143 | + ; FIXME: implement this |
4144 | +"RTN","ZCD",126,0) |
4145 | + ; |
4146 | +"RTN","ZCD",127,0) |
4147 | + ; FIXME: do we need to set $ZINTERRUPT and $PATH? |
4148 | +"RTN","ZCD",128,0) |
4149 | + Q 0 |
4150 | +"RTN","ZCD",129,0) |
4151 | + ; |
4152 | +"RTN","ZCD",130,0) |
4153 | +SWITCH3(INSTANCE) |
4154 | +"RTN","ZCD",131,0) |
4155 | + ; private entry point |
4156 | +"RTN","ZCD",132,0) |
4157 | + ; |
4158 | +"RTN","ZCD",133,0) |
4159 | + ; get new values of $ZG and $ZRO by replacing $$PATH() with |
4160 | +"RTN","ZCD",134,0) |
4161 | + ; $$ROOT()_"/"_INSTANCE. Q 0 without setting $ZG and $ZRO if the |
4162 | +"RTN","ZCD",135,0) |
4163 | + ; resulting paths don't actually exist or we do not have permission to |
4164 | +"RTN","ZCD",136,0) |
4165 | + ; access them |
4166 | +"RTN","ZCD",137,0) |
4167 | + ; |
4168 | +"RTN","ZCD",138,0) |
4169 | + ; FIXME: implement this |
4170 | +"RTN","ZCD",139,0) |
4171 | + ; |
4172 | +"RTN","ZCD",140,0) |
4173 | + ; FIXME: do we need to set $ZINTERRUPT and $PATH? |
4174 | +"RTN","ZCD",141,0) |
4175 | + Q 0 |
4176 | +"RTN","ZCD",142,0) |
4177 | + ; |
4178 | +"RTN","ZCD",143,0) |
4179 | +CD ;Interactive |
4180 | +"RTN","ZCD",144,0) |
4181 | + N Y,DIR |
4182 | +"RTN","ZCD",145,0) |
4183 | + R !,"Namespace: ",DIR |
4184 | +"RTN","ZCD",146,0) |
4185 | + I DIR["^"!(DIR="") Q |
4186 | +"RTN","ZCD",147,0) |
4187 | + D LIST() |
4188 | +"RTN","ZCD",148,0) |
4189 | + I DIR["?" G HELP |
4190 | +"RTN","ZCD",149,0) |
4191 | + I '$D(Y("B",DIR)) W !,"Invalid Namespace" G CD |
4192 | +"RTN","ZCD",150,0) |
4193 | + I $$GTMPATH($$CURRENT())'=$$GTMPATH(DIR) W !,"Inconsistent GTM versions",! G CD |
4194 | +"RTN","ZCD",151,0) |
4195 | + S A=$$SWITCH1(DIR) |
4196 | +"RTN","ZCD",152,0) |
4197 | + S $ZPROMPT=DIR_">" |
4198 | +"RTN","ZCD",153,0) |
4199 | + Q |
4200 | +"RTN","ZCD",154,0) |
4201 | +HELP N A S A="" |
4202 | +"RTN","ZCD",155,0) |
4203 | + F S A=$O(Y("B",A)) Q:A="" W !,A |
4204 | +"RTN","ZCD",156,0) |
4205 | + W ! G CD |
4206 | +"RTN","ZCD",157,0) |
4207 | + Q |
4208 | +"RTN","ZCD",158,0) |
4209 | +SAVE(RN) ;Save a routine |
4210 | +"RTN","ZCD",159,0) |
4211 | + N %,%F,%I,%N,SP,$ETRAP |
4212 | +"RTN","ZCD",160,0) |
4213 | + S $ETRAP="S $ECODE="""" Q" |
4214 | +"RTN","ZCD",161,0) |
4215 | + S %I=$I,SP=" ",%F="/tmp/"_$J_"/"_RN_".m" |
4216 | +"RTN","ZCD",162,0) |
4217 | + ZSYSTEM "mkdir /tmp/"_$J |
4218 | +"RTN","ZCD",163,0) |
4219 | + O %F:(newversion:noreadonly:blocksize=2048:recordsize=2044) U %F |
4220 | +"RTN","ZCD",164,0) |
4221 | + F S XCN=$O(@(DIE_XCN_")")) Q:XCN'>0 S %=@(DIE_XCN_",0)") Q:$E(%,1)="$" I $E(%)'=";" W $P(%,SP)_$C(9)_$P(%,SP,2,99999),! |
4222 | +"RTN","ZCD",165,0) |
4223 | + C %F ;S %N=$$NULL |
4224 | +"RTN","ZCD",166,0) |
4225 | + S ZR=$ZRO,$ZRO=$ZRO_" /tmp/"_$J_"/" |
4226 | +"RTN","ZCD",167,0) |
4227 | + ZLINK RN |
4228 | +"RTN","ZCD",168,0) |
4229 | + ZSYSTEM "rm -r /tmp/"_$J |
4230 | +"RTN","ZCD",169,0) |
4231 | + S $ZRO=ZR |
4232 | +"RTN","ZCD",170,0) |
4233 | + ;C %N |
4234 | +"RTN","ZCD",171,0) |
4235 | + U %I |
4236 | +"RTN","ZCD",172,0) |
4237 | + Q |
4238 | +"RTN","ZIS4GTM") |
4239 | +0^5^B18414491 |
4240 | +"RTN","ZIS4GTM",1,0) |
4241 | +%ZIS4 ;SFISC/AC,RWF,MVB - DEVICE HANDLER SPECIFIC CODE (GT.M 4.3 for Unix/VMS) ;29 Jan 2003 2:59 pm |
4242 | +"RTN","ZIS4GTM",2,0) |
4243 | + ;;8.0;KERNEL;**275**;Jul 10, 1995; |
4244 | +"RTN","ZIS4GTM",3,0) |
4245 | + ; |
4246 | +"RTN","ZIS4GTM",4,0) |
4247 | +OPEN G OPN2:$D(IO(1,IO)) |
4248 | +"RTN","ZIS4GTM",5,0) |
4249 | + S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) |
4250 | +"RTN","ZIS4GTM",6,0) |
4251 | +OPN2 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") |
4252 | +"RTN","ZIS4GTM",7,0) |
4253 | + Q |
4254 | +"RTN","ZIS4GTM",8,0) |
4255 | +NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q |
4256 | +"RTN","ZIS4GTM",9,0) |
4257 | + I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 |
4258 | +"RTN","ZIS4GTM",10,0) |
4259 | + S POP=1 Q |
4260 | +"RTN","ZIS4GTM",11,0) |
4261 | + Q |
4262 | +"RTN","ZIS4GTM",12,0) |
4263 | +OP1 S X="OPNERR^%ZIS4",@^%ZOSF("TRAP"),$ZE="" |
4264 | +"RTN","ZIS4GTM",13,0) |
4265 | + L:$D(%ZISLOCK) +@%ZISLOCK:60 |
4266 | +"RTN","ZIS4GTM",14,0) |
4267 | + O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK |
4268 | +"RTN","ZIS4GTM",15,0) |
4269 | + Q |
4270 | +"RTN","ZIS4GTM",16,0) |
4271 | +OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q |
4272 | +"RTN","ZIS4GTM",17,0) |
4273 | + ; |
4274 | +"RTN","ZIS4GTM",18,0) |
4275 | +O D:%IS["L" ZIO |
4276 | +"RTN","ZIS4GTM",19,0) |
4277 | +LCKGBL ;Lock Global |
4278 | +"RTN","ZIS4GTM",20,0) |
4279 | + I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q |
4280 | +"RTN","ZIS4GTM",21,0) |
4281 | + I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX |
4282 | +"RTN","ZIS4GTM",22,0) |
4283 | +OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") |
4284 | +"RTN","ZIS4GTM",23,0) |
4285 | + I %ZTYPE="CHAN",IO["::""TASK="!(IO["SYS$NET") D ODECNET Q:POP G OXECUTE^%ZIS6 |
4286 | +"RTN","ZIS4GTM",24,0) |
4287 | + S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO) |
4288 | +"RTN","ZIS4GTM",25,0) |
4289 | + N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") |
4290 | +"RTN","ZIS4GTM",26,0) |
4291 | + S %A=%_$E(":",%A]"")_%A |
4292 | +"RTN","ZIS4GTM",27,0) |
4293 | + D O1 I POP D Q |
4294 | +"RTN","ZIS4GTM",28,0) |
4295 | + .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q |
4296 | +"RTN","ZIS4GTM",29,0) |
4297 | + .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q |
4298 | +"RTN","ZIS4GTM",30,0) |
4299 | + ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) |
4300 | +"RTN","ZIS4GTM",31,0) |
4301 | + U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) |
4302 | +"RTN","ZIS4GTM",32,0) |
4303 | + I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 |
4304 | +"RTN","ZIS4GTM",33,0) |
4305 | + ;U:%IS'[0 IO(0) |
4306 | +"RTN","ZIS4GTM",34,0) |
4307 | + G OXECUTE^%ZIS6:IO'["lpr" |
4308 | +"RTN","ZIS4GTM",35,0) |
4309 | + Q |
4310 | +"RTN","ZIS4GTM",36,0) |
4311 | + ; |
4312 | +"RTN","ZIS4GTM",37,0) |
4313 | +O1 ;N $ES,$ET S $ET="G OPNERR^%ZIS4" |
4314 | +"RTN","ZIS4GTM",38,0) |
4315 | + L:$D(%ZISLOCK) +@%ZISLOCK:60 |
4316 | +"RTN","ZIS4GTM",39,0) |
4317 | + I %A["lpr" S IO="lpr",%A="IO:(COMMAND="_$P(%A,":")_":WRITEONLY)::""PIPE""" |
4318 | +"RTN","ZIS4GTM",40,0) |
4319 | + O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK |
4320 | +"RTN","ZIS4GTM",41,0) |
4321 | + S IO("ERROR")="" Q |
4322 | +"RTN","ZIS4GTM",42,0) |
4323 | + ; |
4324 | +"RTN","ZIS4GTM",43,0) |
4325 | + ;Need to find out how to get IP address |
4326 | +"RTN","ZIS4GTM",44,0) |
4327 | +ZIO N %,%1 S (%,%1)=$ZIO |
4328 | +"RTN","ZIS4GTM",45,0) |
4329 | + I $ZV["VMS",%["_TNA" D |
4330 | +"RTN","ZIS4GTM",46,0) |
4331 | + . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") |
4332 | +"RTN","ZIS4GTM",47,0) |
4333 | + . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") |
4334 | +"RTN","ZIS4GTM",48,0) |
4335 | + I $ZV'["VMS" D |
4336 | +"RTN","ZIS4GTM",49,0) |
4337 | + . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO |
4338 | +"RTN","ZIS4GTM",50,0) |
4339 | + S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") |
4340 | +"RTN","ZIS4GTM",51,0) |
4341 | + Q |
4342 | +"RTN","ZIS4GTM",52,0) |
4343 | + ; |
4344 | +"RTN","ZIS4GTM",53,0) |
4345 | +ODECNET Q ; fill me in later |
4346 | +"RTN","ZIS4GTM",54,0) |
4347 | +SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. |
4348 | +"RTN","ZIS4GTM",55,0) |
4349 | + I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N |
4350 | +"RTN","ZIS4GTM",56,0) |
4351 | + I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N |
4352 | +"RTN","ZIS4GTM",57,0) |
4353 | +R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) |
4354 | +"RTN","ZIS4GTM",58,0) |
4355 | + G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC |
4356 | +"RTN","ZIS4GTM",59,0) |
4357 | + S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" |
4358 | +"RTN","ZIS4GTM",60,0) |
4359 | +DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" |
4360 | +"RTN","ZIS4GTM",61,0) |
4361 | + I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS |
4362 | +"RTN","ZIS4GTM",62,0) |
4363 | +OK K %ZDA,%ZFN Q |
4364 | +"RTN","ZIS4GTM",63,0) |
4365 | +N K %ZDA,%ZFN,IO("DOC") S POP=1 Q |
4366 | +"RTN","ZIS4GTM",64,0) |
4367 | +SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q |
4368 | +"RTN","ZIS4GTM",65,0) |
4369 | +SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP") |
4370 | +"RTN","ZIS4GTM",66,0) |
4371 | + O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q |
4372 | +"RTN","ZIS4GTM",67,0) |
4373 | +SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q |
4374 | +"RTN","ZIS4GTM",68,0) |
4375 | +CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q |
4376 | +"RTN","ZIS4GTM",69,0) |
4377 | + S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP") |
4378 | +"RTN","ZIS4GTM",70,0) |
4379 | + S %Z1=+$G(^XTV(8989.3,1,"SPL")) |
4380 | +"RTN","ZIS4GTM",71,0) |
4381 | + F %=0:0 R %X#255:5 Q:$ZA<0 S %2=%X D CL2 G:%Z1<% SPLEX |
4382 | +"RTN","ZIS4GTM",72,0) |
4383 | +SPLEOF I $ZE'["ENDO" Q ;Send error up |
4384 | +"RTN","ZIS4GTM",73,0) |
4385 | +SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q |
4386 | +"RTN","ZIS4GTM",74,0) |
4387 | + ; |
4388 | +"RTN","ZIS4GTM",75,0) |
4389 | +CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q |
4390 | +"RTN","ZIS4GTM",76,0) |
4391 | + I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q |
4392 | +"RTN","ZIS4GTM",77,0) |
4393 | + S ^XMBS(3.519,XS,2,%,0)=%2 Q |
4394 | +"RTN","ZIS4GTM",78,0) |
4395 | + ; |
4396 | +"RTN","ZIS4GTM",79,0) |
4397 | +HFS G HFS^%ZISF |
4398 | +"RTN","ZIS4GTM",80,0) |
4399 | +REWMT(IO,IOPAR) ;Rewind Magtape |
4400 | +"RTN","ZIS4GTM",81,0) |
4401 | + S X="REWERR^%ZIS4",@^%ZOSF("TRAP") |
4402 | +"RTN","ZIS4GTM",82,0) |
4403 | + U IO W *5 |
4404 | +"RTN","ZIS4GTM",83,0) |
4405 | + Q 1 |
4406 | +"RTN","ZIS4GTM",84,0) |
4407 | +REWSDP(IO,IOPAR) ;Rewind SDP |
4408 | +"RTN","ZIS4GTM",85,0) |
4409 | + G REW1 |
4410 | +"RTN","ZIS4GTM",86,0) |
4411 | +REWHFS(IO,IOPAR) ;Rewind Host File. |
4412 | +"RTN","ZIS4GTM",87,0) |
4413 | +REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") |
4414 | +"RTN","ZIS4GTM",88,0) |
4415 | + U IO:(REWIND) |
4416 | +"RTN","ZIS4GTM",89,0) |
4417 | + Q 1 |
4418 | +"RTN","ZIS4GTM",90,0) |
4419 | +REWERR ;Error encountered |
4420 | +"RTN","ZIS4GTM",91,0) |
4421 | + Q 0 |
4422 | +"RTN","ZISHGUX") |
4423 | +0^15^B37875330 |
4424 | +"RTN","ZISHGUX",1,0) |
4425 | +%ZISH ;ISF/AC,RWF - GT.M for UNIX Host file Control ;01/04/2005 08:13 |
4426 | +"RTN","ZISHGUX",2,0) |
4427 | + ;;8.0;KERNEL;**275,306**;Jul 10, 1995; |
4428 | +"RTN","ZISHGUX",3,0) |
4429 | + ; for GT.M for Unix/VMS, version 4.3 |
4430 | +"RTN","ZISHGUX",4,0) |
4431 | + ; |
4432 | +"RTN","ZISHGUX",5,0) |
4433 | +OPENERR ; |
4434 | +"RTN","ZISHGUX",6,0) |
4435 | + Q 0 |
4436 | +"RTN","ZISHGUX",7,0) |
4437 | + ; |
4438 | +"RTN","ZISHGUX",8,0) |
4439 | +OPEN(X1,X2,X3,X4,X5,X6) ;SR. Open file |
4440 | +"RTN","ZISHGUX",9,0) |
4441 | + ;D OPEN^%ZISH([handlename],[directory],filename,[accessmode],[recsize]) |
4442 | +"RTN","ZISHGUX",10,0) |
4443 | + ;X1=handle name |
4444 | +"RTN","ZISHGUX",11,0) |
4445 | + ;X2=directory, X3=filename, X4=access mode |
4446 | +"RTN","ZISHGUX",12,0) |
4447 | + ;X5=new file max record size, X6=Subtype |
4448 | +"RTN","ZISHGUX",13,0) |
4449 | + ; |
4450 | +"RTN","ZISHGUX",14,0) |
4451 | + N %,%1,%2,%IO,%I2,%P,%T,X,Y,$ETRAP |
4452 | +"RTN","ZISHGUX",15,0) |
4453 | + S $ETRAP="D OPNERR^%ZISH" |
4454 | +"RTN","ZISHGUX",16,0) |
4455 | + S U="^",X2=$$DEFDIR($G(X2)),X4=$$UP^XLFSTR(X4) |
4456 | +"RTN","ZISHGUX",17,0) |
4457 | + S Y=$S(X4["A":"append",X4["R":"readonly",X4["W":"newversion",1:"readonly") |
4458 | +"RTN","ZISHGUX",18,0) |
4459 | + S Y=Y_$S(X4["B":":fixed:nowrap:recordsize=512",$G(X5)&(X4["W"):":WIDTH="_+X5,1:"") |
4460 | +"RTN","ZISHGUX",19,0) |
4461 | + S:$E(Y)=":" Y=$E(Y,2,999) S %IO=X2_X3,%I2="%IO:"_$S($L(Y):"("_Y_")",1:"")_":3" |
4462 | +"RTN","ZISHGUX",20,0) |
4463 | + O @%I2 S %T=$T |
4464 | +"RTN","ZISHGUX",21,0) |
4465 | + I '%T S POP=1 Q |
4466 | +"RTN","ZISHGUX",22,0) |
4467 | + S IO=%IO,IO(1,IO)="",IOT="HFS",POP=0 D SUBTYPE^%ZIS3($G(X6)) |
4468 | +"RTN","ZISHGUX",23,0) |
4469 | + I $G(X1)]"" D SAVDEV^%ZISUTL(X1) |
4470 | +"RTN","ZISHGUX",24,0) |
4471 | + U IO U $P ;Enable use of $ZA to test EOF condition. |
4472 | +"RTN","ZISHGUX",25,0) |
4473 | + Q |
4474 | +"RTN","ZISHGUX",26,0) |
4475 | +OPNERR ;error on open |
4476 | +"RTN","ZISHGUX",27,0) |
4477 | + S POP=1,$ECODE="" |
4478 | +"RTN","ZISHGUX",28,0) |
4479 | + U:$G(%P)]"" %P |
4480 | +"RTN","ZISHGUX",29,0) |
4481 | + Q |
4482 | +"RTN","ZISHGUX",30,0) |
4483 | + ; |
4484 | +"RTN","ZISHGUX",31,0) |
4485 | +CLOSE(X) ;SR. Close HFS device not opened by %ZIS. |
4486 | +"RTN","ZISHGUX",32,0) |
4487 | + ;X1=Handle name, IO=device |
4488 | +"RTN","ZISHGUX",33,0) |
4489 | + I IO]"" C IO K IO(1,IO) |
4490 | +"RTN","ZISHGUX",34,0) |
4491 | + I $G(X)]"" D RMDEV^%ZISUTL(X) |
4492 | +"RTN","ZISHGUX",35,0) |
4493 | + D HOME^%ZIS |
4494 | +"RTN","ZISHGUX",36,0) |
4495 | + Q |
4496 | +"RTN","ZISHGUX",37,0) |
4497 | +DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s) |
4498 | +"RTN","ZISHGUX",38,0) |
4499 | + ;S Y=$$DEL^%ZISH("dir path",$NA(array)) |
4500 | +"RTN","ZISHGUX",39,0) |
4501 | + N %ZISH,%ZISHLGR,%ZX,X,%ZXDEL |
4502 | +"RTN","ZISHGUX",40,0) |
4503 | + S %ZX1=$$DEFDIR($G(%ZX1)),%ZXDEL=1,%ZISH="" |
4504 | +"RTN","ZISHGUX",41,0) |
4505 | + F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D |
4506 | +"RTN","ZISHGUX",42,0) |
4507 | + . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH" |
4508 | +"RTN","ZISHGUX",43,0) |
4509 | + . I %ZISH["*" S %ZXDEL=0 Q ; Wild card not allowed. |
4510 | +"RTN","ZISHGUX",44,0) |
4511 | + . S %ZX=$ZSEARCH(%ZX1_%ZISH) |
4512 | +"RTN","ZISHGUX",45,0) |
4513 | + . Q:%ZX']"" ; File doesn't exist - not an error, just quit. |
4514 | +"RTN","ZISHGUX",46,0) |
4515 | + . O %ZX:READONLY:0 |
4516 | +"RTN","ZISHGUX",47,0) |
4517 | + . I '$T S %ZXDEL=0 Q ; Can't open it. |
4518 | +"RTN","ZISHGUX",48,0) |
4519 | + . C %ZX:DELETE |
4520 | +"RTN","ZISHGUX",49,0) |
4521 | + . I $ZSEARCH(%ZX)]"" S %ZXDEL=0 ; Delete was not successful. |
4522 | +"RTN","ZISHGUX",50,0) |
4523 | + Q %ZXDEL |
4524 | +"RTN","ZISHGUX",51,0) |
4525 | +DELERR ;Trap any $ETRAP error, unwind and return. |
4526 | +"RTN","ZISHGUX",52,0) |
4527 | + S $ETRAP="D UNWIND^%ZTER" |
4528 | +"RTN","ZISHGUX",53,0) |
4529 | + S %ZXDEL=0 |
4530 | +"RTN","ZISHGUX",54,0) |
4531 | + D UNWIND^%ZTER |
4532 | +"RTN","ZISHGUX",55,0) |
4533 | + Q |
4534 | +"RTN","ZISHGUX",56,0) |
4535 | + ; |
4536 | +"RTN","ZISHGUX",57,0) |
4537 | +LIST(DIR,LIST,RETURN) ;ef,SR. Set local array holding fl names |
4538 | +"RTN","ZISHGUX",58,0) |
4539 | + ;S Y=$$LIST^ZISH("/dir/","list_root","return_root") |
4540 | +"RTN","ZISHGUX",59,0) |
4541 | + ;list_root can have XX("A*"), XX("test.com")... |
4542 | +"RTN","ZISHGUX",60,0) |
4543 | + ;Both arrays passed as $NA values (closed roots). |
4544 | +"RTN","ZISHGUX",61,0) |
4545 | + ;N %IO,%X,%ZISH,%ZISH1,%ZISHIO,%ZX,POP,X,%ZISHDL1,%ZISHDL2,%ZISHDN1,%ZISHDN2 |
4546 | +"RTN","ZISHGUX",62,0) |
4547 | + ;N $ETRAP,$ESTACK S $ETRAP="G LSTEOF^%ZISH",%ZX1=$$DEFDIR($G(%ZX1)) |
4548 | +"RTN","ZISHGUX",63,0) |
4549 | + ;S %IO=$I,%ZISHDN1="_ZISH"_$J_".TMPA",%ZISHDN2="ZISH"_$J_".TMPB" |
4550 | +"RTN","ZISHGUX",64,0) |
4551 | + ;%ZISHDL1=%ZX1_%ZISHDN1,%ZISHDL2=%ZX1_%ZISHDN2 |
4552 | +"RTN","ZISHGUX",65,0) |
4553 | + ;S $ZT="G SPAWNERR^%ZISH" |
4554 | +"RTN","ZISHGUX",66,0) |
4555 | + ;Init %ZISHDL1, %ZISHDL2 by deleteing them |
4556 | +"RTN","ZISHGUX",67,0) |
4557 | + ;I $ZSEARCH(%ZISHDL1)["ZISH" ZSYSTEM "rm "_%ZISHDL1 |
4558 | +"RTN","ZISHGUX",68,0) |
4559 | + ;I $ZSEARCH(%ZISHDL2)["ZISH" ZSYSTEM "rm "_%ZISHDL2_";*" |
4560 | +"RTN","ZISHGUX",69,0) |
4561 | + ;Get fls, Build listing in %ZISHDL1 with ls |
4562 | +"RTN","ZISHGUX",70,0) |
4563 | + S %ZISH1=0,%ZISH="" |
4564 | +"RTN","ZISHGUX",71,0) |
4565 | + N WANT,GLOB,NAME S WANT="",DIR=$$DEFDIR($G(DIR)) F S WANT=$O(@LIST@(WANT)) Q:WANT="" D |
4566 | +"RTN","ZISHGUX",72,0) |
4567 | + . S GLOB=DIR_WANT,NAME="" |
4568 | +"RTN","ZISHGUX",73,0) |
4569 | + . F S NAME=$ZSEARCH(GLOB) Q:NAME="" S @RETURN@($P(NAME,DIR,2))="" |
4570 | +"RTN","ZISHGUX",74,0) |
4571 | + Q $Q(@RETURN)]"" |
4572 | +"RTN","ZISHGUX",75,0) |
4573 | +LSTEOF S $ZT="" |
4574 | +"RTN","ZISHGUX",76,0) |
4575 | + I $L(%IO) U:$D(IO(1,%IO)) IO |
4576 | +"RTN","ZISHGUX",77,0) |
4577 | + ;C %ZISHDL1 ;:DELETE |
4578 | +"RTN","ZISHGUX",78,0) |
4579 | + ;I $L($ZSEARCH(%ZISHDL2)) ZSYSTEM "DEL "_%ZISHDL2 |
4580 | +"RTN","ZISHGUX",79,0) |
4581 | + ;I $L($ZSEARCH(%ZISHDL1)) ZSYSTEM "DEL "_%ZISHDL1_";*" |
4582 | +"RTN","ZISHGUX",80,0) |
4583 | + S $ECODE="" |
4584 | +"RTN","ZISHGUX",81,0) |
4585 | + Q ($Q(@%ZX3)]"") |
4586 | +"RTN","ZISHGUX",82,0) |
4587 | + ; |
4588 | +"RTN","ZISHGUX",83,0) |
4589 | +LIST1(%ZX,%ZD) ;Get one part of the list |
4590 | +"RTN","ZISHGUX",84,0) |
4591 | + N $ET,$ES S $ET="D LSTERR^%ZISH" |
4592 | +"RTN","ZISHGUX",85,0) |
4593 | + ;ZSYSTEM "ls -1 "_%ZX_" > "_%ZISHDL1 |
4594 | +"RTN","ZISHGUX",86,0) |
4595 | + ;O %ZISHDL1:readonly:1 U %ZISHDL1 |
4596 | +"RTN","ZISHGUX",87,0) |
4597 | + ;F R %X:1 Q:$ZEOF S @%ZX3@(%X)="" |
4598 | +"RTN","ZISHGUX",88,0) |
4599 | + ;C %ZISHDL1:DELETE |
4600 | +"RTN","ZISHGUX",89,0) |
4601 | + N %ZY,%ZI,%ZJ |
4602 | +"RTN","ZISHGUX",90,0) |
4603 | + S %ZY=$ZSEARCH("*.X") ;Clear vector |
4604 | +"RTN","ZISHGUX",91,0) |
4605 | + S %ZY=$P(%ZX,"*") |
4606 | +"RTN","ZISHGUX",92,0) |
4607 | + F S %ZI=$ZSEARCH(%ZX) Q:'$L(%ZI)!(%ZI'[%ZY) S %ZJ=$P(%ZI,%ZD,2),@%ZX3@(%ZJ)="" |
4608 | +"RTN","ZISHGUX",93,0) |
4609 | + Q 1 |
4610 | +"RTN","ZISHGUX",94,0) |
4611 | +LSTERR ;Error in list |
4612 | +"RTN","ZISHGUX",95,0) |
4613 | + I $ZSEARCH(%ZISHDL2)["ZISH" ZSYSTEM "DEL "_%ZISHDL2_";*" |
4614 | +"RTN","ZISHGUX",96,0) |
4615 | + Q 0 |
4616 | +"RTN","ZISHGUX",97,0) |
4617 | + ; |
4618 | +"RTN","ZISHGUX",98,0) |
4619 | +SPAWNERR ;TRAP ERROR OF SPAWN |
4620 | +"RTN","ZISHGUX",99,0) |
4621 | + O %ZISHDL1:READONLY:1 I $T C %ZISHDL1:DELETE |
4622 | +"RTN","ZISHGUX",100,0) |
4623 | + S $ECODE="" |
4624 | +"RTN","ZISHGUX",101,0) |
4625 | + Q 0 |
4626 | +"RTN","ZISHGUX",102,0) |
4627 | + ; |
4628 | +"RTN","ZISHGUX",103,0) |
4629 | +MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl |
4630 | +"RTN","ZISHGUX",104,0) |
4631 | + ;S Y=$$MV^ZISH("/dir/","fl","/dir/","fl") |
4632 | +"RTN","ZISHGUX",105,0) |
4633 | + N X,Y,%ZISHDL1 |
4634 | +"RTN","ZISHGUX",106,0) |
4635 | + S %ZISHDL1="ZISH"_$J_".TMPA",X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1)) |
4636 | +"RTN","ZISHGUX",107,0) |
4637 | + S $ZT="SPAWNERR^%ZISH" |
4638 | +"RTN","ZISHGUX",108,0) |
4639 | + ;Pbv or qit |
4640 | +"RTN","ZISHGUX",109,0) |
4641 | + I (X2="")!(Y2="") Q 0 |
4642 | +"RTN","ZISHGUX",110,0) |
4643 | + ZSYSTEM "mv "_X1_X2_" "_Y1_Y2 ;Use system command |
4644 | +"RTN","ZISHGUX",111,0) |
4645 | + S Y=$ZSEARCH(Y1_Y2) |
4646 | +"RTN","ZISHGUX",112,0) |
4647 | + Q $L(Y)>0 |
4648 | +"RTN","ZISHGUX",113,0) |
4649 | + ; |
4650 | +"RTN","ZISHGUX",114,0) |
4651 | +PWD() ;ef,SR. Print working directory |
4652 | +"RTN","ZISHGUX",115,0) |
4653 | + N Y |
4654 | +"RTN","ZISHGUX",116,0) |
4655 | + S Y=$$DEFDIR("") |
4656 | +"RTN","ZISHGUX",117,0) |
4657 | + S:Y="" Y=$ZDIR |
4658 | +"RTN","ZISHGUX",118,0) |
4659 | + Q Y |
4660 | +"RTN","ZISHGUX",119,0) |
4661 | + ; |
4662 | +"RTN","ZISHGUX",120,0) |
4663 | +DEFDIR(DF) ;ef. Default Dir and frmt |
4664 | +"RTN","ZISHGUX",121,0) |
4665 | + S DF=$G(DF) Q:DF="." "" ;Special way to get current dir. |
4666 | +"RTN","ZISHGUX",122,0) |
4667 | + S:DF="" DF=$G(^XTV(8989.3,1,"DEV")) |
4668 | +"RTN","ZISHGUX",123,0) |
4669 | + ;Check syntax, VMS needs : or [ ] |
4670 | +"RTN","ZISHGUX",124,0) |
4671 | + I ^%ZOSF("OS")["VMS" D Q DF ;***EXIT FOR VMS/GTM |
4672 | +"RTN","ZISHGUX",125,0) |
4673 | + . N P1,P2 |
4674 | +"RTN","ZISHGUX",126,0) |
4675 | + . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2) |
4676 | +"RTN","ZISHGUX",127,0) |
4677 | + . E S P1="",P2=DF |
4678 | +"RTN","ZISHGUX",128,0) |
4679 | + . I P1="",P2["$" S DF=P2 Q ;Assume a logical |
4680 | +"RTN","ZISHGUX",129,0) |
4681 | + . I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]" |
4682 | +"RTN","ZISHGUX",130,0) |
4683 | + . S DF=P1_P2 |
4684 | +"RTN","ZISHGUX",131,0) |
4685 | + . Q |
4686 | +"RTN","ZISHGUX",132,0) |
4687 | + ; |
4688 | +"RTN","ZISHGUX",133,0) |
4689 | + ;Check syntax, Unix check leading & trailing "/" |
4690 | +"RTN","ZISHGUX",134,0) |
4691 | + I "./"'[$E(DF) S DF="/"_DF |
4692 | +"RTN","ZISHGUX",135,0) |
4693 | + I $E(DF,$L(DF))'="/" S DF=DF_"/" |
4694 | +"RTN","ZISHGUX",136,0) |
4695 | + Q DF |
4696 | +"RTN","ZISHGUX",137,0) |
4697 | +STATUS() ;ef,SR. Return EOF status |
4698 | +"RTN","ZISHGUX",138,0) |
4699 | + U $I |
4700 | +"RTN","ZISHGUX",139,0) |
4701 | + Q $ZEOF |
4702 | +"RTN","ZISHGUX",140,0) |
4703 | + ; |
4704 | +"RTN","ZISHGUX",141,0) |
4705 | +EOF(X) ;Eof flag, Pass in $ZA |
4706 | +"RTN","ZISHGUX",142,0) |
4707 | + Q X |
4708 | +"RTN","ZISHGUX",143,0) |
4709 | +QL(X) ;Qlfrs |
4710 | +"RTN","ZISHGUX",144,0) |
4711 | + Q:X="" |
4712 | +"RTN","ZISHGUX",145,0) |
4713 | + S:$E(X)'="-" X="-"_X |
4714 | +"RTN","ZISHGUX",146,0) |
4715 | + Q |
4716 | +"RTN","ZISHGUX",147,0) |
4717 | +FL(X) ;Fl len |
4718 | +"RTN","ZISHGUX",148,0) |
4719 | + N ZOSHP1,ZOSHP2 |
4720 | +"RTN","ZISHGUX",149,0) |
4721 | + S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2) |
4722 | +"RTN","ZISHGUX",150,0) |
4723 | + I $L(ZOSHP1)>14 S X=4 Q |
4724 | +"RTN","ZISHGUX",151,0) |
4725 | + I $L(ZOSHP2)>8 S X=4 Q |
4726 | +"RTN","ZISHGUX",152,0) |
4727 | + Q |
4728 | +"RTN","ZISHGUX",153,0) |
4729 | + ; |
4730 | +"RTN","ZISHGUX",154,0) |
4731 | +MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref. |
4732 | +"RTN","ZISHGUX",155,0) |
4733 | + ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB |
4734 | +"RTN","ZISHGUX",156,0) |
4735 | + N I,F,MX |
4736 | +"RTN","ZISHGUX",157,0) |
4737 | + S OVF=$G(OVF,"%ZISHOF") |
4738 | +"RTN","ZISHGUX",158,0) |
4739 | + S %ZISHI=$$QS^DDBRAP(HF,IX),MX=$$QL^DDBRAP(HF) ; |
4740 | +"RTN","ZISHGUX",159,0) |
4741 | + S F=$NA(@HF,IX-1) ;Get first part |
4742 | +"RTN","ZISHGUX",160,0) |
4743 | + I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1 |
4744 | +"RTN","ZISHGUX",161,0) |
4745 | + I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root |
4746 | +"RTN","ZISHGUX",162,0) |
4747 | + S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow |
4748 | +"RTN","ZISHGUX",163,0) |
4749 | + F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$$QS^DDBRAP(HF,I) |
4750 | +"RTN","ZISHGUX",164,0) |
4751 | + S %ZISHF=%ZISHF_")" |
4752 | +"RTN","ZISHGUX",165,0) |
4753 | + Q |
4754 | +"RTN","ZISHGUX",166,0) |
4755 | +FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global |
4756 | +"RTN","ZISHGUX",167,0) |
4757 | + ;p1=host file directory |
4758 | +"RTN","ZISHGUX",168,0) |
4759 | + ;p2=host file name |
4760 | +"RTN","ZISHGUX",169,0) |
4761 | + ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT |
4762 | +"RTN","ZISHGUX",170,0) |
4763 | + ;p4=INCREMENT SUBSCRIPT |
4764 | +"RTN","ZISHGUX",171,0) |
4765 | + ;p5=Overflow subscript, defaults to "OVF" |
4766 | +"RTN","ZISHGUX",172,0) |
4767 | + N %ZA,%ZB,%ZC,%ZL,X,%OVFCNT,%CONT |
4768 | +"RTN","ZISHGUX",173,0) |
4769 | + N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHLGR,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY,POP,%ZISUB,%EXIT |
4770 | +"RTN","ZISHGUX",174,0) |
4771 | + S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF") |
4772 | +"RTN","ZISHGUX",175,0) |
4773 | + D MAKEREF(%ZX3,%ZX4,"%ZISHOF") |
4774 | +"RTN","ZISHGUX",176,0) |
4775 | + D OPEN^%ZISH(,%ZX1,%ZX2,"R") |
4776 | +"RTN","ZISHGUX",177,0) |
4777 | + I POP Q 0 |
4778 | +"RTN","ZISHGUX",178,0) |
4779 | + N $ETRAP S %EXIT=0,$ETRAP="S %ZA=1,%EXIT=1,$ECODE="""" Q" |
4780 | +"RTN","ZISHGUX",179,0) |
4781 | + U IO F K %XX D READNXT(.%XX) Q:$$EOF(%ZA) D |
4782 | +"RTN","ZISHGUX",180,0) |
4783 | + . S @%ZISHF=%XX |
4784 | +"RTN","ZISHGUX",181,0) |
4785 | + . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT)) S @%ZISHO=%XX(%OVFCNT) |
4786 | +"RTN","ZISHGUX",182,0) |
4787 | + . S %ZISHI=%ZISHI+1 |
4788 | +"RTN","ZISHGUX",183,0) |
4789 | + . Q |
4790 | +"RTN","ZISHGUX",184,0) |
4791 | + D CLOSE() ;Normal exit |
4792 | +"RTN","ZISHGUX",185,0) |
4793 | + Q '%EXIT |
4794 | +"RTN","ZISHGUX",186,0) |
4795 | + ; |
4796 | +"RTN","ZISHGUX",187,0) |
4797 | +ERREOF D CLOSE() ;Got error Reading file |
4798 | +"RTN","ZISHGUX",188,0) |
4799 | + Q 0 |
4800 | +"RTN","ZISHGUX",189,0) |
4801 | + ; |
4802 | +"RTN","ZISHGUX",190,0) |
4803 | +READNXT(REC) ; |
4804 | +"RTN","ZISHGUX",191,0) |
4805 | + N T,I,X,% |
4806 | +"RTN","ZISHGUX",192,0) |
4807 | + U IO R X:2 S %ZA=$ZEOF,REC=$E(X,1,255) |
4808 | +"RTN","ZISHGUX",193,0) |
4809 | + Q:$L(X)<256 |
4810 | +"RTN","ZISHGUX",194,0) |
4811 | + S %=256 F I=1:1 Q:$L(X)<% S REC(I)=$E(X,%,%+254),%=%+255 |
4812 | +"RTN","ZISHGUX",195,0) |
4813 | + Q |
4814 | +"RTN","ZISHGUX",196,0) |
4815 | +GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file. |
4816 | +"RTN","ZISHGUX",197,0) |
4817 | + ;Previously name LOAD |
4818 | +"RTN","ZISHGUX",198,0) |
4819 | + ;p1=$NAME of global reference |
4820 | +"RTN","ZISHGUX",199,0) |
4821 | + ;p2=incrementing subscript |
4822 | +"RTN","ZISHGUX",200,0) |
4823 | + ;p3=host file directory |
4824 | +"RTN","ZISHGUX",201,0) |
4825 | + ;p4=host file name |
4826 | +"RTN","ZISHGUX",202,0) |
4827 | + N %ZISHY,%ZISHLGR,%ZISHOX |
4828 | +"RTN","ZISHGUX",203,0) |
4829 | + S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"W") |
4830 | +"RTN","ZISHGUX",204,0) |
4831 | + Q %ZISHY |
4832 | +"RTN","ZISHGUX",205,0) |
4833 | + ; |
4834 | +"RTN","ZISHGUX",206,0) |
4835 | +GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file. |
4836 | +"RTN","ZISHGUX",207,0) |
4837 | + ; |
4838 | +"RTN","ZISHGUX",208,0) |
4839 | + ;p1=$NAME of global reference |
4840 | +"RTN","ZISHGUX",209,0) |
4841 | + ;p2=incrementing subscript |
4842 | +"RTN","ZISHGUX",210,0) |
4843 | + ;p3=host file directory |
4844 | +"RTN","ZISHGUX",211,0) |
4845 | + ;p4=host file name |
4846 | +"RTN","ZISHGUX",212,0) |
4847 | + N %ZISHY |
4848 | +"RTN","ZISHGUX",213,0) |
4849 | + S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"A") |
4850 | +"RTN","ZISHGUX",214,0) |
4851 | + Q %ZISHY |
4852 | +"RTN","ZISHGUX",215,0) |
4853 | + ; |
4854 | +"RTN","ZISHGUX",216,0) |
4855 | +MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ; |
4856 | +"RTN","ZISHGUX",217,0) |
4857 | + ;p1=$NAME of global reference |
4858 | +"RTN","ZISHGUX",218,0) |
4859 | + ;p2=incrementing subscript |
4860 | +"RTN","ZISHGUX",219,0) |
4861 | + ;p3=host file directory |
4862 | +"RTN","ZISHGUX",220,0) |
4863 | + ;p4=host file name |
4864 | +"RTN","ZISHGUX",221,0) |
4865 | + N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHLGR,%ZISHS,%ZISHOX,IO,%ZX,Y |
4866 | +"RTN","ZISHGUX",222,0) |
4867 | + D MAKEREF(%ZX1,%ZX2) |
4868 | +"RTN","ZISHGUX",223,0) |
4869 | + D OPEN^%ZISH(,%ZX3,%ZX4,%ZX5) ;Default dir set in open |
4870 | +"RTN","ZISHGUX",224,0) |
4871 | + I POP Q 0 |
4872 | +"RTN","ZISHGUX",225,0) |
4873 | + N X |
4874 | +"RTN","ZISHGUX",226,0) |
4875 | + N $ETRAP S $ETRAP="",X="ERREOF^%ZISH",@^%ZOSF("TRAP") |
4876 | +"RTN","ZISHGUX",227,0) |
4877 | + F Q:'($D(@%ZISHF)#2) S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,! |
4878 | +"RTN","ZISHGUX",228,0) |
4879 | + D CLOSE() ;Normal Exit |
4880 | +"RTN","ZISHGUX",229,0) |
4881 | + Q 1 |
4882 | +"RTN","ZISHGUX",230,0) |
4883 | + ; |
4884 | +"RTN","ZISTCPS") |
4885 | +0^25^B18372148 |
4886 | +"RTN","ZISTCPS",1,0) |
4887 | +%ZISTCPS ;ISF/RWF MSC/JDA - DEVICE HANDLER TCP/IP SERVER CALLS ;06/20/2005 09:11 |
4888 | +"RTN","ZISTCPS",2,0) |
4889 | + ;;8.0;KERNEL;**78,118,127,225,275,388,JDA**;Jul 10, 1995 |
4890 | +"RTN","ZISTCPS",3,0) |
4891 | + Q |
4892 | +"RTN","ZISTCPS",4,0) |
4893 | + ; |
4894 | +"RTN","ZISTCPS",5,0) |
4895 | +CLOSE ;Close and reset |
4896 | +"RTN","ZISTCPS",6,0) |
4897 | + G CLOSE^%ZISTCP |
4898 | +"RTN","ZISTCPS",7,0) |
4899 | + Q |
4900 | +"RTN","ZISTCPS",8,0) |
4901 | + ; |
4902 | +"RTN","ZISTCPS",9,0) |
4903 | + ;In ZRULE, set ZISQUIT=1 to quit |
4904 | +"RTN","ZISTCPS",10,0) |
4905 | +LISTEN(SOCK,RTN,ZRULE) ;Listen on socket, start routine |
4906 | +"RTN","ZISTCPS",11,0) |
4907 | + N %A,ZISOS,X,NIO,EXIT |
4908 | +"RTN","ZISTCPS",12,0) |
4909 | + N $ES,$ET S $ETRAP="D OPNERR^%ZISTCPS" |
4910 | +"RTN","ZISTCPS",13,0) |
4911 | + S ZISOS=^%ZOSF("OS"),ZRULE=$G(ZRULE) |
4912 | +"RTN","ZISTCPS",14,0) |
4913 | + S POP=1 |
4914 | +"RTN","ZISTCPS",15,0) |
4915 | + D GETENV^%ZOSV S U="^",XUENV=Y,XQVOL=$P(Y,U,2) |
4916 | +"RTN","ZISTCPS",16,0) |
4917 | + S POP=1 D LONT:ZISOS["OpenM",LGTM:ZISOS["GT.M" |
4918 | +"RTN","ZISTCPS",17,0) |
4919 | + I 'POP C NIO ;Close port |
4920 | +"RTN","ZISTCPS",18,0) |
4921 | + Q |
4922 | +"RTN","ZISTCPS",19,0) |
4923 | + ; |
4924 | +"RTN","ZISTCPS",20,0) |
4925 | + ; |
4926 | +"RTN","ZISTCPS",21,0) |
4927 | +LONT ;Open port in Accept mode with standard terminators. |
4928 | +"RTN","ZISTCPS",22,0) |
4929 | + N %ZA,NEWCHAR |
4930 | +"RTN","ZISTCPS",23,0) |
4931 | + S NIO="|TCP|"_SOCK,EXIT=0 |
4932 | +"RTN","ZISTCPS",24,0) |
4933 | + ;(adr:sock:term:ibuf:obuf:queue) |
4934 | +"RTN","ZISTCPS",25,0) |
4935 | + O NIO:(:SOCK:"AT"::512:512:10):30 Q:'$T S POP=0 U NIO |
4936 | +"RTN","ZISTCPS",26,0) |
4937 | + ;Wait on read for a connect |
4938 | +"RTN","ZISTCPS",27,0) |
4939 | +LONT2 F U NIO R *NEWCHAR:30 S EXIT=$$EXIT Q:$T!EXIT |
4940 | +"RTN","ZISTCPS",28,0) |
4941 | + I EXIT C NIO Q |
4942 | +"RTN","ZISTCPS",29,0) |
4943 | + ;JOB params (:Concurrent Server bit:principal input:principal output) |
4944 | +"RTN","ZISTCPS",30,0) |
4945 | + J CHILDONT^%ZISTCPS(NIO,RTN):(:16::):10 S %ZA=$ZA |
4946 | +"RTN","ZISTCPS",31,0) |
4947 | + I %ZA\8196#2=1 W *-2 ;Job failed to clear bit |
4948 | +"RTN","ZISTCPS",32,0) |
4949 | + G LONT2 |
4950 | +"RTN","ZISTCPS",33,0) |
4951 | + ; |
4952 | +"RTN","ZISTCPS",34,0) |
4953 | +CHILDONT(IO,RTN) ;Child process for OpenM |
4954 | +"RTN","ZISTCPS",35,0) |
4955 | + S $ETRAP="D ^%ZTER L HALT",IO=$ZU(53) |
4956 | +"RTN","ZISTCPS",36,0) |
4957 | + U IO:(::"-M") ;Work like DSM |
4958 | +"RTN","ZISTCPS",37,0) |
4959 | + S NEWJOB=$$NEWOK |
4960 | +"RTN","ZISTCPS",38,0) |
4961 | + I 'NEWJOB W "421 Service temporarily down.",$C(13,10),! |
4962 | +"RTN","ZISTCPS",39,0) |
4963 | + I NEWJOB K NEWJOB D VAR,@RTN |
4964 | +"RTN","ZISTCPS",40,0) |
4965 | + HALT |
4966 | +"RTN","ZISTCPS",41,0) |
4967 | + ; |
4968 | +"RTN","ZISTCPS",42,0) |
4969 | +VAR ;Setup IO variables |
4970 | +"RTN","ZISTCPS",43,0) |
4971 | + S IO(0)=IO,IO(1,IO)="",POP=0 |
4972 | +"RTN","ZISTCPS",44,0) |
4973 | + S IOT="TCP",IOST="P-TCP",IOST(0)=0 |
4974 | +"RTN","ZISTCPS",45,0) |
4975 | + S IOF=$$FLUSHCHR^%ZISTCP |
4976 | +"RTN","ZISTCPS",46,0) |
4977 | + S ^XUTL("XQ",$J,0)=$$DT^XLFDT |
4978 | +"RTN","ZISTCPS",47,0) |
4979 | + Q |
4980 | +"RTN","ZISTCPS",48,0) |
4981 | +NEWOK() ;Is it OK to start a new process |
4982 | +"RTN","ZISTCPS",49,0) |
4983 | + I $G(^%ZIS(14.5,"LOGON",^%ZOSF("VOL"))) Q 0 |
4984 | +"RTN","ZISTCPS",50,0) |
4985 | + I $$AVJ^%ZOSV()<3 Q 0 |
4986 | +"RTN","ZISTCPS",51,0) |
4987 | + Q 1 |
4988 | +"RTN","ZISTCPS",52,0) |
4989 | +OPNERR ; |
4990 | +"RTN","ZISTCPS",53,0) |
4991 | + S POP=1,EXIT=1,IO("ERROR")=$ECODE,$ECODE="" |
4992 | +"RTN","ZISTCPS",54,0) |
4993 | + Q |
4994 | +"RTN","ZISTCPS",55,0) |
4995 | +EXIT() ;See if time to exit |
4996 | +"RTN","ZISTCPS",56,0) |
4997 | + I $$S^%ZTLOAD Q 1 |
4998 | +"RTN","ZISTCPS",57,0) |
4999 | + N ZISQUIT S ZISQUIT=0 |
5000 | +"RTN","ZISTCPS",58,0) |
The diff has been truncated for viewing.