XWBVLL ;OIFO-Oakland/REM - M2M Broker Listener ;12/29/2010
;;1.1;RPC BROKER;**28,41,34,62,63**;Mar 28, 1997;Build 4
;Per VHA Directive 6402, this routine should not be modified
;
QUIT
;
;p41 - fixed infinite loop bug in SYSERR.
; - new Cache/VMS tcpip entry point, called from XWBSERVER_START.COM file.
;p34 - added "BrokerM2M" in message type - SYSERR.
; - removed the quotes (") after 'M:' - SYSERRS.
; - new entry point to job off the listener for Cashe- STRT^XWBVLL(PORT).
; - clear locks when error occurs - SYSERR.
; - halt for read/write errors - SYSERR
;
START(SOCKET) ;Entry point for Cache/NT
;May be called directly to start the listener.
;SOCKET -is the port# to start the listener on.
I ^%ZOSF("OS")'["OpenM" Q ;Quits if not a Cache OS.
D LISTEN^%ZISTCPS(SOCKET,"SPAWN^XWBVLL")
Q
;
UCX ;Old entry point NOT used anymore. *p55*
;DMS/VMS UCX entry point, called from XWBSERVER_START.COM file,
;listener, % = <input variable>
;IF $G(%)="" DO ^%ZTER QUIT
SET (IO,IO(0))="SYS$NET"
; **VMS specific code, need to share device**
OPEN IO:(TCPDEV):60 ELSE SET ^TMP("XWB DSM CONNECT FAILURE",$H)="" QUIT
USE IO
DO SPAWN
QUIT
;
STRT(PORT) ;*p34-This entry is called from option "XWB M2M CACHE LISTENER" and jobs off the listener for Cashe/NT. Will call START.
;PORT -is the port# to start the listener on.
J START^XWBVLL(PORT)::5 ;Used in place of TaskMan
Q
;
CACHEVMS ;Cache/VMS tcpip entry point, called from XWBSERVER_START.COM fLle *p41*
;Update the SET (IO)="SYS$NET" *p55*
SET (IO,IO(0))=$S($ZV["VMS":"SYS$NET",1:$P) ;Support for both VMS/TCPIP and Linux/xinetd *p55*
; **CACHE/VMS specific code**
OPEN IO::60 ELSE SET ^TMP("XWB DSM CONNECT FAILURE",$H)="" QUIT
X "U IO:(::""-M"")" ;Packet mode like DSM
DO SPAWN
QUIT
;
SPAWN ; -- spawned process
NEW U,DTIME,XWBROOT,XWBAVC,XWBSTOP
SET U="^",DUZ=0,DUZ(0)="",DTIME=900,XWBROOT=$NA(^TMP("XWBVLL",$J)),XWBSTOP=0
;
; -- initialize tcp processing variables
DO INIT^XWBRL
;
; -- set error trap
NEW $ESTACK,$ETRAP S $ETRAP="D SYSERR^XWBVLL"
;Get IP from client
S IO("IP")=$$GETPEER^%ZOSV()
; -- change job name if possible
;DO SETNM^%ZOSV("XWBSERVER: Server") ;**M2M - comment out for now
DO SAVDEV^%ZISUTL("XWBM2M SERVER") ;**M2M save off server IO
S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG",,"Q")
I XWBDEBUG D LOG^XWBRPC("Server Start @ "_$$NOW^XLFDT)
;check that XUS AV CODE is the 1st or 2nd RPC call P62
I '$$GET^XPAR("SYS","XWB62",1,"Q") F XWBAVC=1:1:2 D NXTCALL Q:DUZ
S XWBAVC=0
; process rest of messages; loop until told to stop
D
.I '$$GET^XPAR("SYS","XWB62",1,"Q") Q:'DUZ
.F DO NXTCALL QUIT:XWBSTOP
;
; -- final/clean tcp processing variables
D RMDEV^%ZISUTL("XWBM2M SERVER") ;**M2M remove server IO
Q
;
NXTCALL ; -- do next call
NEW DT,X,XWBREAD,XWBTO,XWBFIRST,XWBOK,XWBRL,BUG
;
; -- setup environment variables
SET DT=$$DT^XLFDT(),XWBREAD=20,XWBTO=36000,XWBFIRST=1 ;p63
;
; -- clean intake global - root is request data
KILL @XWBROOT
;
; -- set parameters for RawLink
SET XWBRL("TIME OUT")=36000
SET XWBRL("READ CHARACTERS")=20
SET XWBRL("FIRST READ")=1
SET XWBRL("STORE")=XWBROOT
SET XWBRL("STOP FLAG")=XWBSTOP
;
; -- read from socket
SET XWBOK=$$READ^XWBRL(XWBROOT,.XWBREAD,.XWBTO,.XWBFIRST,.XWBSTOP)
;
;**TESTING **REM
;For debugging - hard set ^TMP(..."DEBUG") and ^TMP(..."CNT") to 1
I $G(^TMP("XWBM2M","DEBUG")) D
. S XWBCNT=(^TMP("XWBM2M","CNT"))+1
. M ^TMP("XWBM2MSV","REQUEST",XWBCNT)=^TMP("XWBVLL",$J)
. S ^TMP("XWBM2M","CNT")=XWBCNT
. Q
;
;**TESING **RWF
I $G(XWBDEBUG) D
. N CNT
. S CNT=$G(^TMP("XWBM2ML",$J))+1,^($J)=CNT
. M ^TMP("XWBM2ML",$J,CNT)=^TMP("XWBVLL",$J)
. Q
;
IF 'XWBOK GOTO NXTCALLQ
;
; -- call request manager
SET XWBOK=$$EN^XWBRM(XWBROOT)
;
NXTCALLQ ; -- exit
;
QUIT
;
; ---------------------------------------------------------------------
; System Error Handler
; ---------------------------------------------------------------------
SYSERR ; -- send system error message
;p41-don't new $Etrap, it was causing infinite loop.
;p34-added "BrokerM2M" in message type in SYSERR.
; -halt for read/write errors
NEW XWBDAT,XWBMSG ;,$ETRAP ;*p41
S $ETRAP="D ^%ZTER HALT" ;If we get an error in the error handler just Halt
SET XWBMSG=$$EC^%ZOSV ;Get the error code
D ^%ZTER ;Save off the error
SET XWBDAT("MESSAGE TYPE")="Gov.VA.Med.BrokerM2M.Errors" ;*34
SET XWBDAT("ERRORS",1,"CODE")=1
SET XWBDAT("ERRORS",1,"ERROR TYPE")="system"
SET XWBDAT("ERRORS",1,"CDATA")=1
SET XWBDAT("ERRORS",1,"MESSAGE",1)=$P($TEXT(SYSERRS+1),";;",2)_XWBMSG
;*p34-will halt for read/write errors
I XWBMSG["<READ>" HALT
DO ERROR^XWBUTL(.XWBDAT)
D UNWIND^%ZTER ;Return to NXTCALL loop
L ;Clear locks *p34
Q
;
SYSERRS ; -- application errors
;*p34-removed the quotes (") after 'M:'
;;A system error occurred in M:
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBVLL 5016 printed Apr 09, 2024@21:39:56 Page 2
XWBVLL ;OIFO-Oakland/REM - M2M Broker Listener ;12/29/2010
+1 ;;1.1;RPC BROKER;**28,41,34,62,63**;Mar 28, 1997;Build 4
+2 ;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
+6 ;p41 - fixed infinite loop bug in SYSERR.
+7 ; - new Cache/VMS tcpip entry point, called from XWBSERVER_START.COM file.
+8 ;p34 - added "BrokerM2M" in message type - SYSERR.
+9 ; - removed the quotes (") after 'M:' - SYSERRS.
+10 ; - new entry point to job off the listener for Cashe- STRT^XWBVLL(PORT).
+11 ; - clear locks when error occurs - SYSERR.
+12 ; - halt for read/write errors - SYSERR
+13 ;
START(SOCKET) ;Entry point for Cache/NT
+1 ;May be called directly to start the listener.
+2 ;SOCKET -is the port# to start the listener on.
+3 ;Quits if not a Cache OS.
IF ^%ZOSF("OS")'["OpenM"
QUIT
+4 DO LISTEN^%ZISTCPS(SOCKET,"SPAWN^XWBVLL")
+5 QUIT
+6 ;
UCX ;Old entry point NOT used anymore. *p55*
+1 ;DMS/VMS UCX entry point, called from XWBSERVER_START.COM file,
+2 ;listener, % = <input variable>
+3 ;IF $G(%)="" DO ^%ZTER QUIT
+4 SET (IO,IO(0))="SYS$NET"
+5 ; **VMS specific code, need to share device**
+6 OPEN IO:(TCPDEV):60
IF '$TEST
SET ^TMP("XWB DSM CONNECT FAILURE",$HOROLOG)=""
QUIT
+7 USE IO
+8 DO SPAWN
+9 QUIT
+10 ;
STRT(PORT) ;*p34-This entry is called from option "XWB M2M CACHE LISTENER" and jobs off the listener for Cashe/NT. Will call START.
+1 ;PORT -is the port# to start the listener on.
+2 ;Used in place of TaskMan
JOB START^XWBVLL(PORT)::5
+3 QUIT
+4 ;
CACHEVMS ;Cache/VMS tcpip entry point, called from XWBSERVER_START.COM fLle *p41*
+1 ;Update the SET (IO)="SYS$NET" *p55*
+2 ;Support for both VMS/TCPIP and Linux/xinetd *p55*
SET (IO,IO(0))=$SELECT($ZV["VMS":"SYS$NET",1:$PRINCIPAL)
+3 ; **CACHE/VMS specific code**
+4 OPEN IO::60
IF '$TEST
SET ^TMP("XWB DSM CONNECT FAILURE",$HOROLOG)=""
QUIT
+5 ;Packet mode like DSM
XECUTE "U IO:(::""-M"")"
+6 DO SPAWN
+7 QUIT
+8 ;
SPAWN ; -- spawned process
+1 NEW U,DTIME,XWBROOT,XWBAVC,XWBSTOP
+2 SET U="^"
SET DUZ=0
SET DUZ(0)=""
SET DTIME=900
SET XWBROOT=$NAME(^TMP("XWBVLL",$JOB))
SET XWBSTOP=0
+3 ;
+4 ; -- initialize tcp processing variables
+5 DO INIT^XWBRL
+6 ;
+7 ; -- set error trap
+8 NEW $ESTACK,$ETRAP
SET $ETRAP="D SYSERR^XWBVLL"
+9 ;Get IP from client
+10 SET IO("IP")=$$GETPEER^%ZOSV()
+11 ; -- change job name if possible
+12 ;DO SETNM^%ZOSV("XWBSERVER: Server") ;**M2M - comment out for now
+13 ;**M2M save off server IO
DO SAVDEV^%ZISUTL("XWBM2M SERVER")
+14 SET XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG",,"Q")
+15 IF XWBDEBUG
DO LOG^XWBRPC("Server Start @ "_$$NOW^XLFDT)
+16 ;check that XUS AV CODE is the 1st or 2nd RPC call P62
+17 IF '$$GET^XPAR("SYS","XWB62",1,"Q")
FOR XWBAVC=1:1:2
DO NXTCALL
if DUZ
QUIT
+18 SET XWBAVC=0
+19 ; process rest of messages; loop until told to stop
+20 Begin DoDot:1
+21 IF '$$GET^XPAR("SYS","XWB62",1,"Q")
if 'DUZ
QUIT
+22 FOR
DO NXTCALL
if XWBSTOP
QUIT
End DoDot:1
+23 ;
+24 ; -- final/clean tcp processing variables
+25 ;**M2M remove server IO
DO RMDEV^%ZISUTL("XWBM2M SERVER")
+26 QUIT
+27 ;
NXTCALL ; -- do next call
+1 NEW DT,X,XWBREAD,XWBTO,XWBFIRST,XWBOK,XWBRL,BUG
+2 ;
+3 ; -- setup environment variables
+4 ;p63
SET DT=$$DT^XLFDT()
SET XWBREAD=20
SET XWBTO=36000
SET XWBFIRST=1
+5 ;
+6 ; -- clean intake global - root is request data
+7 KILL @XWBROOT
+8 ;
+9 ; -- set parameters for RawLink
+10 SET XWBRL("TIME OUT")=36000
+11 SET XWBRL("READ CHARACTERS")=20
+12 SET XWBRL("FIRST READ")=1
+13 SET XWBRL("STORE")=XWBROOT
+14 SET XWBRL("STOP FLAG")=XWBSTOP
+15 ;
+16 ; -- read from socket
+17 SET XWBOK=$$READ^XWBRL(XWBROOT,.XWBREAD,.XWBTO,.XWBFIRST,.XWBSTOP)
+18 ;
+19 ;**TESTING **REM
+20 ;For debugging - hard set ^TMP(..."DEBUG") and ^TMP(..."CNT") to 1
+21 IF $GET(^TMP("XWBM2M","DEBUG"))
Begin DoDot:1
+22 SET XWBCNT=(^TMP("XWBM2M","CNT"))+1
+23 MERGE ^TMP("XWBM2MSV","REQUEST",XWBCNT)=^TMP("XWBVLL",$JOB)
+24 SET ^TMP("XWBM2M","CNT")=XWBCNT
+25 QUIT
End DoDot:1
+26 ;
+27 ;**TESING **RWF
+28 IF $GET(XWBDEBUG)
Begin DoDot:1
+29 NEW CNT
+30 SET CNT=$GET(^TMP("XWBM2ML",$JOB))+1
SET ^($JOB)=CNT
+31 MERGE ^TMP("XWBM2ML",$JOB,CNT)=^TMP("XWBVLL",$JOB)
+32 QUIT
End DoDot:1
+33 ;
+34 IF 'XWBOK
GOTO NXTCALLQ
+35 ;
+36 ; -- call request manager
+37 SET XWBOK=$$EN^XWBRM(XWBROOT)
+38 ;
NXTCALLQ ; -- exit
+1 ;
+2 QUIT
+3 ;
+4 ; ---------------------------------------------------------------------
+5 ; System Error Handler
+6 ; ---------------------------------------------------------------------
SYSERR ; -- send system error message
+1 ;p41-don't new $Etrap, it was causing infinite loop.
+2 ;p34-added "BrokerM2M" in message type in SYSERR.
+3 ; -halt for read/write errors
+4 ;,$ETRAP ;*p41
NEW XWBDAT,XWBMSG
+5 ;If we get an error in the error handler just Halt
SET $ETRAP="D ^%ZTER HALT"
+6 ;Get the error code
SET XWBMSG=$$EC^%ZOSV
+7 ;Save off the error
DO ^%ZTER
+8 ;*34
SET XWBDAT("MESSAGE TYPE")="Gov.VA.Med.BrokerM2M.Errors"
+9 SET XWBDAT("ERRORS",1,"CODE")=1
+10 SET XWBDAT("ERRORS",1,"ERROR TYPE")="system"
+11 SET XWBDAT("ERRORS",1,"CDATA")=1
+12 SET XWBDAT("ERRORS",1,"MESSAGE",1)=$PIECE($TEXT(SYSERRS+1),";;",2)_XWBMSG
+13 ;*p34-will halt for read/write errors
+14 IF XWBMSG["<READ>"
HALT
+15 DO ERROR^XWBUTL(.XWBDAT)
+16 ;Return to NXTCALL loop
DO UNWIND^%ZTER
+17 ;Clear locks *p34
LOCK
+18 QUIT
+19 ;
SYSERRS ; -- application errors
+1 ;*p34-removed the quotes (") after 'M:'
+2 ;;A system error occurred in M:
