Merge lp:~joel-sher/openvista-gtm-integration/kidsbuild into lp:openvista-gtm-integration

Proposed by JSHER
Status: Merged
Merge reported by: JSHER
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
Reviewer Review Type Date Requested Status
JSHER Approve
Review via email: mp+6097@code.launchpad.net
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.

Subscribers

People subscribed via source and target branches