source: BMXNET_RPMS_dotNET_UTILITIES-BMX/trunk/k/xwb_0110_113102.k@ 841

Last change on this file since 841 was 645, checked in by Sam Habiel, 15 years ago

Initial Import of BMX.net code

File size: 17.1 KB
Line 
1KIDS Distribution saved on Dec 07, 2009@11:11:21
2Modified XWB Routine to correct $$OS bug and support BMX.net
3**KIDS**:XWB*1.1*113102^
4
5**INSTALL NAME**
6XWB*1.1*113102
7"BLD",7415,0)
8XWB*1.1*113102^RPC BROKER^0^3091207^n
9"BLD",7415,1,0)
10^9.61A^9^9^3091207^^
11"BLD",7415,1,1,0)
12This patch adds support to XWB of routing BMX Broker messages to the
13"BLD",7415,1,2,0)
14BMXMON routine. As such, it provides a uniform entry point for all broker
15"BLD",7415,1,3,0)
16messaging.
17"BLD",7415,1,4,0)
18
19"BLD",7415,1,5,0)
20Produced on July 22 2009 by Sam Habiel for WorldVista.
21"BLD",7415,1,6,0)
22
23"BLD",7415,1,7,0)
24Licensed under WorldVista global license, currently GPL 2.
25"BLD",7415,1,8,0)
26
27"BLD",7415,1,9,0)
28**updated on Aug 29th to handle IPv6 addresses for GT.M**
29"BLD",7415,4,0)
30^9.64PA^^
31"BLD",7415,6.3)
326
33"BLD",7415,"KRN",0)
34^9.67PA^8989.52^19
35"BLD",7415,"KRN",.4,0)
36.4
37"BLD",7415,"KRN",.401,0)
38.401
39"BLD",7415,"KRN",.402,0)
40.402
41"BLD",7415,"KRN",.403,0)
42.403
43"BLD",7415,"KRN",.5,0)
44.5
45"BLD",7415,"KRN",.84,0)
46.84
47"BLD",7415,"KRN",3.6,0)
483.6
49"BLD",7415,"KRN",3.8,0)
503.8
51"BLD",7415,"KRN",9.2,0)
529.2
53"BLD",7415,"KRN",9.8,0)
549.8
55"BLD",7415,"KRN",9.8,"NM",0)
56^9.68A^1^1
57"BLD",7415,"KRN",9.8,"NM",1,0)
58XWBTCPM^^0^B56820596
59"BLD",7415,"KRN",9.8,"NM","B","XWBTCPM",1)
60
61"BLD",7415,"KRN",19,0)
6219
63"BLD",7415,"KRN",19.1,0)
6419.1
65"BLD",7415,"KRN",101,0)
66101
67"BLD",7415,"KRN",409.61,0)
68409.61
69"BLD",7415,"KRN",771,0)
70771
71"BLD",7415,"KRN",870,0)
72870
73"BLD",7415,"KRN",8989.51,0)
748989.51
75"BLD",7415,"KRN",8989.52,0)
768989.52
77"BLD",7415,"KRN",8994,0)
788994
79"BLD",7415,"KRN","B",.4,.4)
80
81"BLD",7415,"KRN","B",.401,.401)
82
83"BLD",7415,"KRN","B",.402,.402)
84
85"BLD",7415,"KRN","B",.403,.403)
86
87"BLD",7415,"KRN","B",.5,.5)
88
89"BLD",7415,"KRN","B",.84,.84)
90
91"BLD",7415,"KRN","B",3.6,3.6)
92
93"BLD",7415,"KRN","B",3.8,3.8)
94
95"BLD",7415,"KRN","B",9.2,9.2)
96
97"BLD",7415,"KRN","B",9.8,9.8)
98
99"BLD",7415,"KRN","B",19,19)
100
101"BLD",7415,"KRN","B",19.1,19.1)
102
103"BLD",7415,"KRN","B",101,101)
104
105"BLD",7415,"KRN","B",409.61,409.61)
106
107"BLD",7415,"KRN","B",771,771)
108
109"BLD",7415,"KRN","B",870,870)
110
111"BLD",7415,"KRN","B",8989.51,8989.51)
112
113"BLD",7415,"KRN","B",8989.52,8989.52)
114
115"BLD",7415,"KRN","B",8994,8994)
116
117"BLD",7415,"QDEF")
118^^^^NO^^^^NO^^NO
119"BLD",7415,"QUES",0)
120^9.62^^
121"MBREQ")
1220
123"PKG",70,-1)
1241^1
125"PKG",70,0)
126RPC BROKER^XWB^Remote Procedure Call Broker
127"PKG",70,20,0)
128^9.402P^^
129"PKG",70,22,0)
130^9.49I^1^1
131"PKG",70,22,1,0)
1321.1^3020529^2971118^1
133"PKG",70,22,1,"PAH",1,0)
134113102^3091207
135"PKG",70,22,1,"PAH",1,1,0)
136^^9^9^3091207
137"PKG",70,22,1,"PAH",1,1,1,0)
138This patch adds support to XWB of routing BMX Broker messages to the
139"PKG",70,22,1,"PAH",1,1,2,0)
140BMXMON routine. As such, it provides a uniform entry point for all broker
141"PKG",70,22,1,"PAH",1,1,3,0)
142messaging.
143"PKG",70,22,1,"PAH",1,1,4,0)
144
145"PKG",70,22,1,"PAH",1,1,5,0)
146Produced on July 22 2009 by Sam Habiel for WorldVista.
147"PKG",70,22,1,"PAH",1,1,6,0)
148
149"PKG",70,22,1,"PAH",1,1,7,0)
150Licensed under WorldVista global license, currently GPL 2.
151"PKG",70,22,1,"PAH",1,1,8,0)
152
153"PKG",70,22,1,"PAH",1,1,9,0)
154**updated on Aug 29th to handle IPv6 addresses for GT.M**
155"QUES","XPF1",0)
156Y
157"QUES","XPF1","??")
158^D REP^XPDH
159"QUES","XPF1","A")
160Shall I write over your |FLAG| File
161"QUES","XPF1","B")
162YES
163"QUES","XPF1","M")
164D XPF1^XPDIQ
165"QUES","XPF2",0)
166Y
167"QUES","XPF2","??")
168^D DTA^XPDH
169"QUES","XPF2","A")
170Want my data |FLAG| yours
171"QUES","XPF2","B")
172YES
173"QUES","XPF2","M")
174D XPF2^XPDIQ
175"QUES","XPI1",0)
176YO
177"QUES","XPI1","??")
178^D INHIBIT^XPDH
179"QUES","XPI1","A")
180Want KIDS to INHIBIT LOGONs during the install
181"QUES","XPI1","B")
182NO
183"QUES","XPI1","M")
184D XPI1^XPDIQ
185"QUES","XPM1",0)
186PO^VA(200,:EM
187"QUES","XPM1","??")
188^D MG^XPDH
189"QUES","XPM1","A")
190Enter the Coordinator for Mail Group '|FLAG|'
191"QUES","XPM1","B")
192
193"QUES","XPM1","M")
194D XPM1^XPDIQ
195"QUES","XPO1",0)
196Y
197"QUES","XPO1","??")
198^D MENU^XPDH
199"QUES","XPO1","A")
200Want KIDS to Rebuild Menu Trees Upon Completion of Install
201"QUES","XPO1","B")
202NO
203"QUES","XPO1","M")
204D XPO1^XPDIQ
205"QUES","XPZ1",0)
206Y
207"QUES","XPZ1","??")
208^D OPT^XPDH
209"QUES","XPZ1","A")
210Want to DISABLE Scheduled Options, Menu Options, and Protocols
211"QUES","XPZ1","B")
212NO
213"QUES","XPZ1","M")
214D XPZ1^XPDIQ
215"QUES","XPZ2",0)
216Y
217"QUES","XPZ2","??")
218^D RTN^XPDH
219"QUES","XPZ2","A")
220Want to MOVE routines to other CPUs
221"QUES","XPZ2","B")
222NO
223"QUES","XPZ2","M")
224D XPZ2^XPDIQ
225"RTN")
2261
227"RTN","XWBTCPM")
2280^1^B56820596
229"RTN","XWBTCPM",1,0)
230XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ; 12/7/09 10:30am
231"RTN","XWBTCPM",2,0)
232 ;;1.1;RPC BROKER;**35,43,49**;Mar 28, 1997;Build 6
233"RTN","XWBTCPM",3,0)
234 ;Local patch 113102 by WV/SMH for BMX.net support
235"RTN","XWBTCPM",4,0)
236 ;Based on: XWBTCPC & XWBTCPL, Modified by ISF/RWF
237"RTN","XWBTCPM",5,0)
238 ;Changed to be started by UCX or %ZISTCPS
239"RTN","XWBTCPM",6,0)
240 ;
241"RTN","XWBTCPM",7,0)
242DSM ;DSM called from ucx, % passed in with device.
243"RTN","XWBTCPM",8,0)
244 D ESET
245"RTN","XWBTCPM",9,0)
246 ;Open the device
247"RTN","XWBTCPM",10,0)
248 S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open
249"RTN","XWBTCPM",11,0)
250 ;Go find the connection type
251"RTN","XWBTCPM",12,0)
252 U XWBTDEV
253"RTN","XWBTCPM",13,0)
254 G CONNTYPE
255"RTN","XWBTCPM",14,0)
256 ;
257"RTN","XWBTCPM",15,0)
258CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
259"RTN","XWBTCPM",16,0)
260 D ESET
261"RTN","XWBTCPM",17,0)
262 S XWBTDEV="SYS$NET"
263"RTN","XWBTCPM",18,0)
264 ; **Cache'/VMS specific code**
265"RTN","XWBTCPM",19,0)
266 O XWBTDEV::5
267"RTN","XWBTCPM",20,0)
268 X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM
269"RTN","XWBTCPM",21,0)
270 G CONNTYPE
271"RTN","XWBTCPM",22,0)
272 ;
273"RTN","XWBTCPM",23,0)
274NT ;entry from ZISTCPS
275"RTN","XWBTCPM",24,0)
276 ;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
277"RTN","XWBTCPM",25,0)
278 D ESET
279"RTN","XWBTCPM",26,0)
280 S XWBTDEV=IO
281"RTN","XWBTCPM",27,0)
282 G CONNTYPE
283"RTN","XWBTCPM",28,0)
284 ;
285"RTN","XWBTCPM",29,0)
286GTMUCX(%) ;From ucx ZFOO
287"RTN","XWBTCPM",30,0)
288 ;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
289"RTN","XWBTCPM",31,0)
290 D ESET
291"RTN","XWBTCPM",32,0)
292 ;GTM specific code
293"RTN","XWBTCPM",33,0)
294 S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
295"RTN","XWBTCPM",34,0)
296 S XWBTDEV=% X "O %:(RECORDSIZE=512)"
297"RTN","XWBTCPM",35,0)
298 G CONNTYPE
299"RTN","XWBTCPM",36,0)
300 ;
301"RTN","XWBTCPM",37,0)
302GTMLNX ;From Linux xinetd script
303"RTN","XWBTCPM",38,0)
304 D ESET
305"RTN","XWBTCPM",39,0)
306 ;GTM specific code
307"RTN","XWBTCPM",40,0)
308 S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
309"RTN","XWBTCPM",41,0)
310 S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
311"RTN","XWBTCPM",42,0)
312 S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
313"RTN","XWBTCPM",43,0)
314 I %["::ffff:" S IO("GTM-IP")=$P(%,"::ffff:",2) ; fake ipv6 support
315"RTN","XWBTCPM",44,0)
316 G CONNTYPE
317"RTN","XWBTCPM",45,0)
318 ;
319"RTN","XWBTCPM",46,0)
320ESET ;Set inital error trap
321"RTN","XWBTCPM",47,0)
322 S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
323"RTN","XWBTCPM",48,0)
324 S X="",@^%ZOSF("TRAP") ;Clear old trap
325"RTN","XWBTCPM",49,0)
326 Q
327"RTN","XWBTCPM",50,0)
328 ;Find the type of connection and jump to the processing routine.
329"RTN","XWBTCPM",51,0)
330CONNTYPE ;
331"RTN","XWBTCPM",52,0)
332 N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
333"RTN","XWBTCPM",53,0)
334 N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
335"RTN","XWBTCPM",54,0)
336 N SOCK,TYPE
337"RTN","XWBTCPM",55,0)
338 D INIT
339"RTN","XWBTCPM",56,0)
340 S XWB=$$BREAD^XWBRW(5,XWBTIME)
341"RTN","XWBTCPM",57,0)
342 D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",XWB="{BMX}":"BMX",1:"Unk"))
343"RTN","XWBTCPM",58,0)
344 I XWB["[XWB]" G NEW
345"RTN","XWBTCPM",59,0)
346 I XWB["{XWB}" G OLD^XWBTCPM1
347"RTN","XWBTCPM",60,0)
348 I XWB["<?xml" G M2M
349"RTN","XWBTCPM",61,0)
350 I XWB["{BMX}" G GTMLNX^BMXMON
351"RTN","XWBTCPM",62,0)
352 I $L($T(OTH^XWBTCPM2)) D OTH^XWBTCPM2 ;See if a special code.
353"RTN","XWBTCPM",63,0)
354 D LOG("Prefix not known: "_XWB)
355"RTN","XWBTCPM",64,0)
356 Q
357"RTN","XWBTCPM",65,0)
358 ;
359"RTN","XWBTCPM",66,0)
360NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
361"RTN","XWBTCPM",67,0)
362 N X,Y,J,XWBVOL
363"RTN","XWBTCPM",68,0)
364 D GETENV^%ZOSV S XWBVOL=$P(Y,"^",2)
365"RTN","XWBTCPM",69,0)
366 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")
367"RTN","XWBTCPM",70,0)
368 I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS?
369"RTN","XWBTCPM",71,0)
370 I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0
371"RTN","XWBTCPM",72,0)
372 Q 1
373"RTN","XWBTCPM",73,0)
374 ;
375"RTN","XWBTCPM",74,0)
376M2M ;M2M Broker
377"RTN","XWBTCPM",75,0)
378 S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL
379"RTN","XWBTCPM",76,0)
380 Q
381"RTN","XWBTCPM",77,0)
382 ;
383"RTN","XWBTCPM",78,0)
384NEW ;New broker
385"RTN","XWBTCPM",79,0)
386 S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108
387"RTN","XWBTCPM",80,0)
388 D SETTIME(1) ;Setup for sign-on timeout
389"RTN","XWBTCPM",81,0)
390 U XWBTDEV D
391"RTN","XWBTCPM",82,0)
392 . N XWB,ERR,NATIP,I
393"RTN","XWBTCPM",83,0)
394 . S ERR=$$PRSP^XWBPRS
395"RTN","XWBTCPM",84,0)
396 . S ERR=$$PRSM^XWBPRS
397"RTN","XWBTCPM",85,0)
398 . S MSG=$G(XWB(4,"CMD")) ;Build connect msg.
399"RTN","XWBTCPM",86,0)
400 . S I="" F S I=$O(XWB(5,"P",I)) Q:I="" S MSG=MSG_U_XWB(5,"P",I)
401"RTN","XWBTCPM",87,0)
402 . ;Get the peer and save that IP.
403"RTN","XWBTCPM",88,0)
404 . S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2)
405"RTN","XWBTCPM",89,0)
406 . I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP
407"RTN","XWBTCPM",90,0)
408 . Q
409"RTN","XWBTCPM",91,0)
410 S X=$$NEWJOB() D:'X LOG("No New Connects")
411"RTN","XWBTCPM",92,0)
412 I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q
413"RTN","XWBTCPM",93,0)
414 D QSND^XWBRW("accept"),LOG("accept") ;Ack
415"RTN","XWBTCPM",94,0)
416 S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4)
417"RTN","XWBTCPM",95,0)
418 S XWBTIP=$G(IO("IP"))
419"RTN","XWBTCPM",96,0)
420 ;start RUM for Broker Handler XWB*1.1*5
421"RTN","XWBTCPM",97,0)
422 D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
423"RTN","XWBTCPM",98,0)
424 ;GTM
425"RTN","XWBTCPM",99,0)
426 I $G(XWBT("PCNT")) D
427"RTN","XWBTCPM",100,0)
428 . S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0
429"RTN","XWBTCPM",101,0)
430 . D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X)
431"RTN","XWBTCPM",102,0)
432 ;We don't use a callback
433"RTN","XWBTCPM",103,0)
434 K XWB,CON,LEN,MSG ;Clean up
435"RTN","XWBTCPM",104,0)
436 ;Attempt to share license, Must have TCP port open first.
437"RTN","XWBTCPM",105,0)
438 U XWBTDEV ;D SHARELIC^%ZOSV(1)
439"RTN","XWBTCPM",106,0)
440 ;setup null device "NULL"
441"RTN","XWBTCPM",107,0)
442 S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D ^%ZTER,EXIT Q
443"RTN","XWBTCPM",108,0)
444 D SAVDEV^%ZISUTL("XWBNULL")
445"RTN","XWBTCPM",109,0)
446 ;change process name
447"RTN","XWBTCPM",110,0)
448 D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV)
449"RTN","XWBTCPM",111,0)
450 ;
451"RTN","XWBTCPM",112,0)
452RESTART ;The error trap returns to here
453"RTN","XWBTCPM",113,0)
454 N $ESTACK S $ETRAP="D ETRAP^XWBTCPM"
455"RTN","XWBTCPM",114,0)
456 S DT=$$DT^XLFDT,DTIME=30
457"RTN","XWBTCPM",115,0)
458 U XWBTDEV D MAIN
459"RTN","XWBTCPM",116,0)
460 D LOG("Exit: "_XWBTBUF)
461"RTN","XWBTCPM",117,0)
462 ;Turn off the error trap for the exit
463"RTN","XWBTCPM",118,0)
464 S $ETRAP=""
465"RTN","XWBTCPM",119,0)
466 D EXIT ;Logout
467"RTN","XWBTCPM",120,0)
468 K XWBR,XWBARY
469"RTN","XWBTCPM",121,0)
470 ;stop RUM for handler XWB*1.1*5
471"RTN","XWBTCPM",122,0)
472 D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
473"RTN","XWBTCPM",123,0)
474 D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
475"RTN","XWBTCPM",124,0)
476 ;Close in the calling script
477"RTN","XWBTCPM",125,0)
478 K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
479"RTN","XWBTCPM",126,0)
480 Q
481"RTN","XWBTCPM",127,0)
482 ;
483"RTN","XWBTCPM",128,0)
484MAIN ; -- main message processing loop. debug at MAIN+1
485"RTN","XWBTCPM",129,0)
486 F D Q:XWBTBUF="#BYE#"
487"RTN","XWBTCPM",130,0)
488 . ;Setup
489"RTN","XWBTCPM",131,0)
490 . S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF=""
491"RTN","XWBTCPM",132,0)
492 . K XWBR,XWBARY,XWBPRT
493"RTN","XWBTCPM",133,0)
494 . ; -- read client request
495"RTN","XWBTCPM",134,0)
496 . S XR=$$BREAD^XWBRW(1,XWBTIME,1)
497"RTN","XWBTCPM",135,0)
498 . I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q
499"RTN","XWBTCPM",136,0)
500 . S XR=XR_$$BREAD^XWBRW(4)
501"RTN","XWBTCPM",137,0)
502 . I XR="#BYE#" D Q ;Check for exit
503"RTN","XWBTCPM",138,0)
504 . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#"
505"RTN","XWBTCPM",139,0)
506 . . Q
507"RTN","XWBTCPM",140,0)
508 . S TYPE=(XR="[XWB]") ;check HDR
509"RTN","XWBTCPM",141,0)
510 . I 'TYPE D LOG("Bad Header: "_XR) Q
511"RTN","XWBTCPM",142,0)
512 . D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC
513"RTN","XWBTCPM",143,0)
514 . IF XWBTCMD="#BYE#" D Q
515"RTN","XWBTCPM",144,0)
516 . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD
517"RTN","XWBTCPM",145,0)
518 . . Q
519"RTN","XWBTCPM",146,0)
520 . U XWBTDEV
521"RTN","XWBTCPM",147,0)
522 . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
523"RTN","XWBTCPM",148,0)
524 . ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return
525"RTN","XWBTCPM",149,0)
526 . I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer
527"RTN","XWBTCPM",150,0)
528 Q ;End Of Main
529"RTN","XWBTCPM",151,0)
530 ;
531"RTN","XWBTCPM",152,0)
532 ;
533"RTN","XWBTCPM",153,0)
534ETRAP ; -- on trapped error, send error info to client
535"RTN","XWBTCPM",154,0)
536 N XWBERC,XWBERR
537"RTN","XWBTCPM",155,0)
538 ;Change trapping during trap.
539"RTN","XWBTCPM",156,0)
540 S $ETRAP="D ^%ZTER,EXIT^XWBTCPM HALT"
541"RTN","XWBTCPM",157,0)
542 S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
543"RTN","XWBTCPM",158,0)
544 I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
545"RTN","XWBTCPM",159,0)
546 D ^%ZTER ;%ZTER clears $ZE and $ZCODE
547"RTN","XWBTCPM",160,0)
548 D LOG("In ETRAP: "_XWBERC) ;Log
549"RTN","XWBTCPM",161,0)
550 I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")!(XWBERC["IOEOF") D EXIT HALT
551"RTN","XWBTCPM",162,0)
552 U XWBTDEV
553"RTN","XWBTCPM",163,0)
554 I $G(XWBT("PCNT")) L ^XUTL("XUSYS",$J,0)
555"RTN","XWBTCPM",164,0)
556 E L ;Clear Locks
557"RTN","XWBTCPM",165,0)
558 ;I XWBOS'="DSM" D
559"RTN","XWBTCPM",166,0)
560 S XWBPTYPE=1 ;So SNDERR won't check XWBR
561"RTN","XWBTCPM",167,0)
562 ;D SNDERR^XWBRW,WRITE^XWBRW($C(24)_XWBERR_$C(4))
563"RTN","XWBTCPM",168,0)
564 D ESND^XWBRW($C(24)_XWBERR_$C(4))
565"RTN","XWBTCPM",169,0)
566 S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99,"
567"RTN","XWBTCPM",170,0)
568 Q
569"RTN","XWBTCPM",171,0)
570 ;
571"RTN","XWBTCPM",172,0)
572CLEANP ;Clean up the partion
573"RTN","XWBTCPM",173,0)
574 N XWBTDEV,XWBNULL D KILL^XUSCLEAN
575"RTN","XWBTCPM",174,0)
576 Q
577"RTN","XWBTCPM",175,0)
578 ;
579"RTN","XWBTCPM",176,0)
580STYPE(X,WRAP) ;For backward compatability only
581"RTN","XWBTCPM",177,0)
582 I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
583"RTN","XWBTCPM",178,0)
584 Q $$RTRNFMT^XWBLIB(X)
585"RTN","XWBTCPM",179,0)
586 ;
587"RTN","XWBTCPM",180,0)
588BREAD(L,T) ;read tcp buffer, L is length
589"RTN","XWBTCPM",181,0)
590 Q $$BREAD^XWBRW(L,$G(T))
591"RTN","XWBTCPM",182,0)
592 ;
593"RTN","XWBTCPM",183,0)
594CHPRN(N) ;change process name
595"RTN","XWBTCPM",184,0)
596 ;Change process name to N
597"RTN","XWBTCPM",185,0)
598 D SETNM^%ZOSV($E(N,1,15))
599"RTN","XWBTCPM",186,0)
600 Q
601"RTN","XWBTCPM",187,0)
602 ;
603"RTN","XWBTCPM",188,0)
604SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
605"RTN","XWBTCPM",189,0)
606 S XWBTIME=$S($G(%):90,$G(XWBVER)>1.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=2
607"RTN","XWBTCPM",190,0)
608 I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000)
609"RTN","XWBTCPM",191,0)
610 Q
611"RTN","XWBTCPM",192,0)
612TIMEOUT ;Do this on MAIN loop timeout
613"RTN","XWBTCPM",193,0)
614 I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q
615"RTN","XWBTCPM",194,0)
616 ;Sign-on timeout
617"RTN","XWBTCPM",195,0)
618 S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
619"RTN","XWBTCPM",196,0)
620 D SND^XWBRW
621"RTN","XWBTCPM",197,0)
622 Q
623"RTN","XWBTCPM",198,0)
624 ;
625"RTN","XWBTCPM",199,0)
626OS() ;Return the OS
627"RTN","XWBTCPM",200,0)
628 ; Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM") //SMH
629"RTN","XWBTCPM",201,0)
630 Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["GT.M":"GT.M",^("OS")["OpenM":"OpenM",1:"MSM")
631"RTN","XWBTCPM",202,0)
632 ;
633"RTN","XWBTCPM",203,0)
634INIT ;Setup
635"RTN","XWBTCPM",204,0)
636 S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF=""
637"RTN","XWBTCPM",205,0)
638 S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
639"RTN","XWBTCPM",206,0)
640 S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
641"RTN","XWBTCPM",207,0)
642 S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1
643"RTN","XWBTCPM",208,0)
644 D LOGSTART^XWBDLOG("XWBTCPM")
645"RTN","XWBTCPM",209,0)
646 Q
647"RTN","XWBTCPM",210,0)
648 ;
649"RTN","XWBTCPM",211,0)
650DEBUG ;Entry point for debug, Build a server to get the connect
651"RTN","XWBTCPM",212,0)
652 ;DSM sample;ZDEBUG ON S $ZB(1)="SERV+1^XWBTCPM:1",$ZB="ETRAP+1^XWBTCPM:1"
653"RTN","XWBTCPM",213,0)
654 W !,"Before running this entry point set your debugger to stop at"
655"RTN","XWBTCPM",214,0)
656 W !,"the place you want to debug. Some spots to use:"
657"RTN","XWBTCPM",215,0)
658 W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
659"RTN","XWBTCPM",216,0)
660 W !,"or location of your choice.",!
661"RTN","XWBTCPM",217,0)
662 W !,"IP Socket to Listen on: " R SOCK:300 Q:'$T!(SOCK["^")
663"RTN","XWBTCPM",218,0)
664 ;Use %ZISTCP to do a single server
665"RTN","XWBTCPM",219,0)
666 D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
667"RTN","XWBTCPM",220,0)
668 U $P W !,"Done"
669"RTN","XWBTCPM",221,0)
670 Q
671"RTN","XWBTCPM",222,0)
672SERV ;Callback from the server
673"RTN","XWBTCPM",223,0)
674 S XWBTDEV=IO,XWBTIME(1)=3600 D INIT
675"RTN","XWBTCPM",224,0)
676 S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5
677"RTN","XWBTCPM",225,0)
678 D NEW
679"RTN","XWBTCPM",226,0)
680 S IO("C")=1 ;Cause the Listenr to stop
681"RTN","XWBTCPM",227,0)
682 Q
683"RTN","XWBTCPM",228,0)
684 ;
685"RTN","XWBTCPM",229,0)
686EXIT ;Close out
687"RTN","XWBTCPM",230,0)
688 I $G(DUZ) D LOGOUT^XUSRB
689"RTN","XWBTCPM",231,0)
690 I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1)
691"RTN","XWBTCPM",232,0)
692 Q
693"RTN","XWBTCPM",233,0)
694 ;
695"RTN","XWBTCPM",234,0)
696LOG(MSG) ;Record Debug Info
697"RTN","XWBTCPM",235,0)
698 D:$G(XWBDEBUG) LOG^XWBDLOG(MSG)
699"RTN","XWBTCPM",236,0)
700 Q
701"RTN","XWBTCPM",237,0)
702 ;
703"VER")
7048.0^22.0
705**END**
706**END**
Note: See TracBrowser for help on using the repository browser.