- 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 Jan 18, 2025@03:38:44 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: