XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ;05/27/15 14:40
;;1.1;RPC BROKER;**35,43,49,53,64**;Mar 28, 1997;Build 12
;Per VA Directive 6402, this routine should not be modified.
;
;Changed to be started by TCPIP service or %ZISTCPS
;
DSM ;DSM called from ucx, % passed in with device.
D ESET
;Open the device
S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open
;Go find the connection type
U XWBTDEV
G CONNTYPE
;
CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
D ESET
S XWBTDEV=$S($ZV["VMS":"SYS$NET",1:$P) ;Support for both VMS/TCPIP and Linux/xinetd
; **Cache'/VMS specific code**
O XWBTDEV::5
X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM
G CONNTYPE
;
NT ;entry from ZISTCPS
;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
D ESET
S XWBTDEV=IO
G CONNTYPE
;
GTMUCX(%) ;From ucx ZFOO
;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
D ESET
;GTM specific code
S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
S XWBTDEV=% X "O %:(RECORDSIZE=512)"
G CONNTYPE
;
GTMLNX ;From Linux xinetd script
D ESET
;GTM specific code
S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
G CONNTYPE
;
ESET ;Set inital error trap
S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
S X="",@("$ZT=X") ;Clear old trap
Q
;Find the type of connection and jump to the processing routine.
CONNTYPE ;
N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
N SOCK,TYPE
D INIT
S XWB=$$BREAD^XWBRW(5,XWBTIME)
D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",XWB="~BSE~":"BSE",XWB="~EAC~":"EAC",XWB="~SVR~":"SVR",1:"Unk")) ; XWB*1.1*XX
I XWB["<?xml" G M2M
I XWB["[XWB]" G NEW
I XWB["{XWB}" G OLD^XWBTCPM1 ;Deprecated in XWB*1.1*60, to be removed when no longer being used
I $L($T(OTH^XWBTCPM2)) D OTH^XWBTCPM2 ;See if a special code.
I '$L($T(OTH^XWBTCPM2)) D LOG("Prefix not known: "_XWB) ; XWB*1.1*XX
Q
;
NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
N X,Y,J,XWBVOL
D GETENV^%ZOSV S XWBVOL=$P(Y,"^",2)
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")
I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS?
I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0
Q 1
;
M2M ;M2M Broker
S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL
Q
;
NEW ;New broker
S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108
D SETTIME(1) ;Setup for sign-on timeout
U XWBTDEV D
. N XWB,ERR,NATIP,I
. S ERR=$$PRSP^XWBPRS
. S ERR=$$PRSM^XWBPRS
. S MSG=$G(XWB(4,"CMD")) ;Build connect msg.
. S I="" F S I=$O(XWB(5,"P",I)) Q:I="" S MSG=MSG_U_XWB(5,"P",I)
. ;Get the peer and save that IP.
. S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2)
. I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP
. Q
S X=$$NEWJOB() D:'X LOG("No New Connects")
I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q
D QSND^XWBRW("accept"),LOG("accept") ;Ack
S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4)
S XWBTIP=$G(IO("IP"))
;start RUM for Broker Handler XWB*1.1*5
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
;GTM
I $G(XWBT("PCNT")) D
. S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0
. D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X)
;We don't use a callback
K XWB,CON,LEN,MSG ;Clean up
;Attempt to share license, Must have TCP port open first.
U XWBTDEV ;D SHARELIC^%ZOSV(1)
;setup null device "NULL"
S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D LOG(XWBERROR),EXIT Q
D SAVDEV^%ZISUTL("XWBNULL")
;change process name
D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV)
;
RESTART ;The error trap returns to here
N $ESTACK S $ETRAP="D ETRAP^XWBTCPM(0)"
S DT=$$DT^XLFDT,DTIME=30
U XWBTDEV D MAIN
D LOG("Exit: "_XWBTBUF)
;Turn off the error trap for the exit
S $ETRAP=""
D EXIT ;Logout
K XWBR,XWBARY
;stop RUM for handler XWB*1.1*5
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
;Close in the calling script
K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
Q
;
MAIN ; -- main message processing loop. debug at MAIN+1
F D Q:XWBTBUF="#BYE#"
. ;Setup
. S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF=""
. K XWBR,XWBARY,XWBPRT
. ; -- read client request
. S XR=$$BREAD^XWBRW(1,XWBTIME,1)
. I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q
. S XR=XR_$$BREAD^XWBRW(4)
. I XR="#BYE#" D Q ;Check for exit
. . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#"
. . Q
. S TYPE=(XR="[XWB]") ;check HDR
. I 'TYPE D LOG("Bad Header: "_XR) Q
. D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC
. IF XWBTCMD="#BYE#" D Q
. . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD
. . Q
. U XWBTDEV
. S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
. ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return
. I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer
Q ;End Of Main
;
;
ETRAP(EXIT) ; -- on trapped error, send error info to client
N XWBERC,XWBERR
;Change trapping during trap.
S $ETRAP="D ^%ZTER,ETRAP^XWBTCPM(1)"
S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
D ^%ZTER ;%ZTER clears $ZE and $ZCODE
D LOG("In ETRAP: "_XWBERC) ;Log
I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")!(XWBERC["IOEOF") D EXIT X "HALT "
U XWBTDEV
I $G(XWBT("PCNT")) L +^XUTL("XUSYS",$J,0):99
E L ;Clear Locks
;
D ESND^XWBRW($C(24)_XWBERR_$C(4))
I EXIT D EXIT X "HALT "
S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99,"
Q
;
CLEANP ;Clean up the partion
N XWBTDEV,XWBNULL D KILL^XUSCLEAN
Q
;
STYPE(X,WRAP) ;For backward compatability only
I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
Q $$RTRNFMT^XWBLIB(X)
;
BREAD(L,T) ;read tcp buffer, L is length
Q $$BREAD^XWBRW(L,$G(T))
;
CHPRN(N) ;change process name
;Change process name to N
D SETNM^%ZOSV($E(N,1,15))
Q
;
SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
; Increased timeout period (%=1) during signon from 90 to 180 for accessibility reasons
S XWBTIME=$S($G(%):180,$G(XWBVER)>1.1:$$BAT^XUPARAM,1:36000),XWBTIME(1)=5 ; (*p35)
Q
TIMEOUT ;Do this on MAIN loop timeout
I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q
;Sign-on timeout
S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
D SND^XWBRW
Q
;
OS() ;Return the OS
Q $S(^%ZOSF("OS")["OpenM":"OpenM",^%ZOSF("OS")["GT.M":"GT.M",^("OS")["DSM":"DSM",1:"UNK")
;
INIT ;Setup
S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF=""
S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1
D LOGSTART^XWBDLOG("XWBTCPM")
Q
;
DEBUG ;Entry point for debug, Build a server to get the connect
;Cache sample;ZB SERV+1^XWBTCPM:"L+" ZB ETRAP+1^XWBTCPM:"B"
W !,"Before running this entry point set your debugger to stop at"
W !,"the place you want to debug. Some spots to use:"
W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
W !,"or location of your choice.",!
W !,"IP Socket to Listen on: " R SOCK:300,! Q:'$T!(SOCK["^")
;Use %ZISTCP to do a single server
D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
U $P W !,"Done"
Q
SERV ;Callback from the server
S XWBTDEV=IO,XWBTIME(1)=3600 D INIT
S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5
D NEW
S IO("C")=1 ;Cause the Listenr to stop
Q
;
EXIT ;Close out
I $G(DUZ) D LOGOUT^XUSRB
I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1)
Q
;
LOG(MSG) ;Record Debug Info
D:$G(XWBDEBUG) LOG^XWBDLOG(MSG)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBTCPM 8017 printed Sep 23, 2025@20:13:56 Page 2
XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ;05/27/15 14:40
+1 ;;1.1;RPC BROKER;**35,43,49,53,64**;Mar 28, 1997;Build 12
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Changed to be started by TCPIP service or %ZISTCPS
+5 ;
DSM ;DSM called from ucx, % passed in with device.
+1 DO ESET
+2 ;Open the device
+3 ;Special UCX/DSM open
SET XWBTDEV=%
XECUTE "O XWBTDEV:(TCPDEV):60"
+4 ;Go find the connection type
+5 USE XWBTDEV
+6 GOTO CONNTYPE
+7 ;
CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
+1 DO ESET
+2 ;Support for both VMS/TCPIP and Linux/xinetd
SET XWBTDEV=$SELECT($ZV["VMS":"SYS$NET",1:$PRINCIPAL)
+3 ; **Cache'/VMS specific code**
+4 OPEN XWBTDEV::5
+5 ;Packet mode like DSM
XECUTE "U XWBTDEV:(::""-M"")"
+6 GOTO CONNTYPE
+7 ;
NT ;entry from ZISTCPS
+1 ;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
+2 DO ESET
+3 SET XWBTDEV=IO
+4 GOTO CONNTYPE
+5 ;
GTMUCX(%) ;From ucx ZFOO
+1 ;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
+2 DO ESET
+3 ;GTM specific code
+4 SET @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
+5 SET XWBTDEV=%
XECUTE "O %:(RECORDSIZE=512)"
+6 GOTO CONNTYPE
+7 ;
GTMLNX ;From Linux xinetd script
+1 DO ESET
+2 ;GTM specific code
+3 SET @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
+4 SET XWBTDEV=$PRINCIPAL
XECUTE "U XWBTDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
+5 SET %=""
SET @("%=$ZTRNLNM(""REMOTE_HOST"")")
if $LENGTH(%)
SET IO("GTM-IP")=%
+6 GOTO CONNTYPE
+7 ;
ESET ;Set inital error trap
+1 ;Set up the error trap
SET U="^"
SET $ETRAP="D ^%ZTER H"
+2 ;Clear old trap
SET X=""
SET @("$ZT=X")
+3 QUIT
+4 ;Find the type of connection and jump to the processing routine.
CONNTYPE ;
+1 NEW XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
+2 NEW XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
+3 NEW SOCK,TYPE
+4 DO INIT
+5 SET XWB=$$BREAD^XWBRW(5,XWBTIME)
+6 ; XWB*1.1*XX
DO LOG("MSG format is "_XWB_" type "_$SELECT(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",XWB="~BSE~":"BSE",XWB="~EAC~":"EAC",XWB="~SVR~":"SVR",1:"Unk"))
+7 IF XWB["<?xml"
GOTO M2M
+8 IF XWB["[XWB]"
GOTO NEW
+9 ;Deprecated in XWB*1.1*60, to be removed when no longer being used
IF XWB["{XWB}"
GOTO OLD^XWBTCPM1
+10 ;See if a special code.
IF $LENGTH($TEXT(OTH^XWBTCPM2))
DO OTH^XWBTCPM2
+11 ; XWB*1.1*XX
IF '$LENGTH($TEXT(OTH^XWBTCPM2))
DO LOG("Prefix not known: "_XWB)
+12 QUIT
+13 ;
NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
+1 NEW X,Y,J,XWBVOL
+2 DO GETENV^%ZOSV
SET XWBVOL=$PIECE(Y,"^",2)
+3 SET X=$ORDER(^XTV(8989.3,1,4,"B",XWBVOL,0))
SET J=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1")
+4 ;Check INHIBIT LOGONS?
IF $GET(^%ZIS(14.5,"LOGON",XWBVOL))
QUIT 0
+5 IF $DATA(^%ZOSF("ACTJ"))
XECUTE ^("ACTJ")
IF $PIECE(J,U,3)
IF ($PIECE(J,U,3)'>Y)
QUIT 0
+6 QUIT 1
+7 ;
M2M ;M2M Broker
+1 SET XWBRBUF=XWB_XWBRBUF
SET (IO,IO(0))=XWBTDEV
GOTO SPAWN^XWBVLL
+2 QUIT
+3 ;
NEW ;New broker
+1 SET U="^"
SET DUZ=0
SET DUZ(0)=""
SET XWBVER=1.108
+2 ;Setup for sign-on timeout
DO SETTIME(1)
+3 USE XWBTDEV
Begin DoDot:1
+4 NEW XWB,ERR,NATIP,I
+5 SET ERR=$$PRSP^XWBPRS
+6 SET ERR=$$PRSM^XWBPRS
+7 ;Build connect msg.
SET MSG=$GET(XWB(4,"CMD"))
+8 SET I=""
FOR
SET I=$ORDER(XWB(5,"P",I))
if I=""
QUIT
SET MSG=MSG_U_XWB(5,"P",I)
+9 ;Get the peer and save that IP.
+10 SET NATIP=$$GETPEER^%ZOSV
if '$LENGTH(NATIP)
SET NATIP=$PIECE(MSG,"^",2)
+11 IF NATIP'=$PIECE(MSG,"^",2)
SET $PIECE(MSG,"^",2)=NATIP
+12 QUIT
End DoDot:1
+13 SET X=$$NEWJOB()
if 'X
DO LOG("No New Connects")
+14 IF ($PIECE(MSG,U)'="TCPConnect")!('X)
DO QSND^XWBRW("reject")
DO LOG("reject: "_MSG)
QUIT
+15 ;Ack
DO QSND^XWBRW("accept")
DO LOG("accept")
+16 SET IO("IP")=$PIECE(MSG,U,2)
SET XWBTSKT=$PIECE(MSG,U,3)
SET XWBCLMAN=$PIECE(MSG,U,4)
+17 SET XWBTIP=$GET(IO("IP"))
+18 ;start RUM for Broker Handler XWB*1.1*5
+19 DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
+20 ;GTM
+21 IF $GET(XWBT("PCNT"))
Begin DoDot:1
+22 SET X=$NAME(^XUTL("XUSYS",$JOB,1))
LOCK +@X:0
+23 DO COUNT^XUSCNT(1)
DO SETLOCK^XUSCNT(X)
End DoDot:1
+24 ;We don't use a callback
+25 ;Clean up
KILL XWB,CON,LEN,MSG
+26 ;Attempt to share license, Must have TCP port open first.
+27 ;D SHARELIC^%ZOSV(1)
USE XWBTDEV
+28 ;setup null device "NULL"
+29 SET %ZIS="0H"
SET IOP="NULL"
DO ^%ZIS
SET XWBNULL=IO
IF POP
SET XWBERROR="No NULL device"
DO LOG(XWBERROR)
DO EXIT
QUIT
+30 DO SAVDEV^%ZISUTL("XWBNULL")
+31 ;change process name
+32 DO CHPRN("ip"_$PIECE(XWBTIP,".",3,4)_":"_XWBTDEV)
+33 ;
RESTART ;The error trap returns to here
+1 NEW $ESTACK
SET $ETRAP="D ETRAP^XWBTCPM(0)"
+2 SET DT=$$DT^XLFDT
SET DTIME=30
+3 USE XWBTDEV
DO MAIN
+4 DO LOG("Exit: "_XWBTBUF)
+5 ;Turn off the error trap for the exit
+6 SET $ETRAP=""
+7 ;Logout
DO EXIT
+8 KILL XWBR,XWBARY
+9 ;stop RUM for handler XWB*1.1*5
+10 DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
+11 DO USE^%ZISUTL("XWBNULL")
DO CLOSE^%ZISUTL("XWBNULL")
+12 ;Close in the calling script
+13 KILL SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
+14 QUIT
+15 ;
MAIN ; -- main message processing loop. debug at MAIN+1
+1 FOR
Begin DoDot:1
+2 ;Setup
+3 SET XWBAPVER=0
SET XWBTBUF=""
SET XWBTCMD=""
SET XWBRBUF=""
+4 KILL XWBR,XWBARY,XWBPRT
+5 ; -- read client request
+6 SET XR=$$BREAD^XWBRW(1,XWBTIME,1)
+7 IF '$LENGTH(XR)
DO LOG("Timeout: "_XWBTIME)
SET XWBTBUF="#BYE#"
QUIT
+8 SET XR=XR_$$BREAD^XWBRW(4)
+9 ;Check for exit
IF XR="#BYE#"
Begin DoDot:2
+10 DO QSND^XWBRW("#BYE#")
DO LOG("BYE CMD")
SET XWBTBUF="#BYE#"
+11 QUIT
End DoDot:2
QUIT
+12 ;check HDR
SET TYPE=(XR="[XWB]")
+13 IF 'TYPE
DO LOG("Bad Header: "_XR)
QUIT
+14 ;Read the NEW Msg parameters and call RPC
DO CALLP^XWBPRS(.XWBR,$GET(XWBDEBUG))
+15 IF XWBTCMD="#BYE#"
Begin DoDot:2
+16 DO QSND^XWBRW("#BYE#")
DO LOG("BYE CMD")
SET XWBTBUF=XWBTCMD
+17 QUIT
End DoDot:2
QUIT
+18 USE XWBTDEV
+19 SET XWBPTYPE=$SELECT('$DATA(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
+20 ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return
+21 ;Return data,flush buffer
IF '$GET(XWBPRT)
DO SND^XWBRW
End DoDot:1
if XWBTBUF="#BYE#"
QUIT
+22 ;End Of Main
QUIT
+23 ;
+24 ;
ETRAP(EXIT) ; -- on trapped error, send error info to client
+1 NEW XWBERC,XWBERR
+2 ;Change trapping during trap.
+3 SET $ETRAP="D ^%ZTER,ETRAP^XWBTCPM(1)"
+4 SET XWBERC=$EXTRACT($$EC^%ZOSV,1,200)
SET XWBERR="M ERROR="_XWBERC_$CHAR(13,10)_"LAST REF="_$$LGR^%ZOSV
+5 IF $ECODE["U411"
SET XWBERROR="U411"
SET XWBSEC=""
SET XWBERR="Data Transfer Error to Server"
+6 ;%ZTER clears $ZE and $ZCODE
DO ^%ZTER
+7 ;Log
DO LOG("In ETRAP: "_XWBERC)
+8 IF (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")!(XWBERC["IOEOF")
DO EXIT
XECUTE "HALT "
+9 USE XWBTDEV
+10 IF $GET(XWBT("PCNT"))
LOCK +^XUTL("XUSYS",$JOB,0):99
+11 ;Clear Locks
IF '$TEST
LOCK
+12 ;
+13 DO ESND^XWBRW($CHAR(24)_XWBERR_$CHAR(4))
+14 IF EXIT
DO EXIT
XECUTE "HALT "
+15 SET $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM"
SET $ECODE=",U99,"
+16 QUIT
+17 ;
CLEANP ;Clean up the partion
+1 NEW XWBTDEV,XWBNULL
DO KILL^XUSCLEAN
+2 QUIT
+3 ;
STYPE(X,WRAP) ;For backward compatability only
+1 IF $DATA(WRAP)
QUIT $$RTRNFMT^XWBLIB($GET(X),WRAP)
+2 QUIT $$RTRNFMT^XWBLIB(X)
+3 ;
BREAD(L,T) ;read tcp buffer, L is length
+1 QUIT $$BREAD^XWBRW(L,$GET(T))
+2 ;
CHPRN(N) ;change process name
+1 ;Change process name to N
+2 DO SETNM^%ZOSV($EXTRACT(N,1,15))
+3 QUIT
+4 ;
SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
+1 ; Increased timeout period (%=1) during signon from 90 to 180 for accessibility reasons
+2 ; (*p35)
SET XWBTIME=$SELECT($GET(%):180,$GET(XWBVER)>1.1:$$BAT^XUPARAM,1:36000)
SET XWBTIME(1)=5
+3 QUIT
TIMEOUT ;Do this on MAIN loop timeout
+1 IF $GET(DUZ)>0
DO QSND^XWBRW("#BYE#")
QUIT
+2 ;Sign-on timeout
+3 SET XWBR(0)=0
SET XWBR(1)=1
SET XWBR(2)=""
SET XWBR(3)="TIME-OUT"
SET XWBPTYPE=2
+4 DO SND^XWBRW
+5 QUIT
+6 ;
OS() ;Return the OS
+1 QUIT $SELECT(^%ZOSF("OS")["OpenM":"OpenM",^%ZOSF("OS")["GT.M":"GT.M",^("OS")["DSM":"DSM",1:"UNK")
+2 ;
INIT ;Setup
+1 SET U="^"
SET XWBTIME=10
SET XWBOS=$$OS
SET XWBDEBUG=0
SET XWBRBUF=""
+2 SET XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
+3 SET XWBT("BF")=$SELECT(XWBOS="GT.M":"#",1:"!")
+4 SET XWBT("PCNT")=0
IF XWBOS="GT.M"
IF $LENGTH($TEXT(^XUSCNT))
SET XWBT("PCNT")=1
+5 DO LOGSTART^XWBDLOG("XWBTCPM")
+6 QUIT
+7 ;
DEBUG ;Entry point for debug, Build a server to get the connect
+1 ;Cache sample;ZB SERV+1^XWBTCPM:"L+" ZB ETRAP+1^XWBTCPM:"B"
+2 WRITE !,"Before running this entry point set your debugger to stop at"
+3 WRITE !,"the place you want to debug. Some spots to use:"
+4 WRITE !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
+5 WRITE !,"or location of your choice.",!
+6 WRITE !,"IP Socket to Listen on: "
READ SOCK:300,!
if '$TEST!(SOCK["^")
QUIT
+7 ;Use %ZISTCP to do a single server
+8 DO LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
+9 USE $PRINCIPAL
WRITE !,"Done"
+10 QUIT
SERV ;Callback from the server
+1 SET XWBTDEV=IO
SET XWBTIME(1)=3600
DO INIT
+2 ;R MSG#5
SET XWBDEBUG=1
SET MSG=$$BREAD^XWBRW(5,60)
+3 DO NEW
+4 ;Cause the Listenr to stop
SET IO("C")=1
+5 QUIT
+6 ;
EXIT ;Close out
+1 IF $GET(DUZ)
DO LOGOUT^XUSRB
+2 IF $GET(XWBT("PCNT"))
DO COUNT^XUSCNT(-1)
+3 QUIT
+4 ;
LOG(MSG) ;Record Debug Info
+1 if $GET(XWBDEBUG)
DO LOG^XWBDLOG(MSG)
+2 QUIT
+3 ;
