- XOBVLL ;MJK/ALB - VistALink Listen and Spawn Code ; 07/27/2002 13:00
- ;;1.6;VistALink;**4,6**;Apr 5,2017;Build 33
- ;Per VA Directive 6402, this routine should not be modified.
- Q
- ;
- ; ***deprecated*** tag ; Use START^XOBVTCP instead
- START(SOCKET) ; -- start listener
- D START^XOBVTCP(SOCKET)
- Q
- ;
- ; ***deprecated*** tag ; Use UCX^XOBVTCP instead
- UCX ; -- VMS TCPIP (UCX) multi-thread entry point
- ; -- Called from VistALink .com files
- G UCX^XOBVTCP
- ;
- SPAWN ; -- spawned process
- N X,XOBSTOP,XOBPORT,XOBHDLR,XOBLASTR,XOBCMREF
- ;
- S XOBSTOP=0
- S XOBPORT=IO
- S U="^"
- ;
- ; -- initialize timestamp for last time request made (used for debugging)
- S XOBLASTR=0
- ;
- ; -- set error trap
- ;Set up the error trap
- ; * * *
- ;S $ET="D APPERROR^%ZTER(""VistALink Error $P(XOBMSG,"": "",2 "") HALT" ;*4
- S $ET="D APPERROR^%ZTER(""VistALink Error ""_$P(XOBMSG,"": "",2)) HALT" ;*6
- ; * * *
- ;
- ; -- attempt to share the license; must have TCP port open first
- U XOBPORT I $T(SHARELIC^%ZOSV)'="" D SHARELIC^%ZOSV(1)
- ;
- ; -- start RUM for VistALink Handler
- D LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1)
- ;
- ; -- cache/initialize startup request handlers
- S X=$$CACHE^XOBVRH(.XOBHDLR)
- I 'X D RMERR^XOBVRM(184001,$P(X,U,2)) Q
- ;
- ; -- initialize tcp processing variables
- D INIT^XOBVSKT
- ;
- ; -- change job name if possible
- D SETNM^%ZOSV("VLink_"_$$CNV^XLFUTL($J,16))
- ;
- ; -- setup for Connection Mgr: get ref; kill data @ ref
- S XOBCMREF=$$GETREF^XOBUZAP1()
- D KILL^XOBUZAP0(XOBCMREF)
- ;
- ; -- loop until told to stop
- F D NXTCALL Q:XOBSTOP
- ;
- ; -- kill ^XTMP ref node
- D KILL^XOBUZAP0(XOBCMREF)
- ;
- ; -- final/clean tcp processing variables
- D FINAL^XOBVSKT
- ;
- ; -- stop RUM for VistALink Handler
- D LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,2)
- ;
- Q
- ;
- NXTCALL ; -- do next call
- N X,XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBOK,XOBRL,XOBDATA
- ;
- ; -- set up error trap
- N $ES S $ET="DO SYSERR^XOBVLL"
- ;
- ; -- setup environment variables
- N DIQUIET S DIQUIET=1
- S U="^",DTIME=$G(DTIME,900),DT=$$DT^XLFDT()
- ;
- ; -- set ^XTMP for Connection Mgr usage if DUZ not 1st piece
- I '$$GETDUZ^XOBUZAP0(XOBCMREF) D
- . N XOBDUZ,XOBIP
- . S XOBDUZ=$G(XOBSYS("DUZ"),$G(DUZ))
- . S XOBIP=$G(IO("IP"))
- . D SETVI^XOBUZAP0(XOBCMREF,XOBDUZ,XOBIP,$$GETDESC^XOBUZAP1())
- ;
- ; -- initialize 'current' request handler to empty string
- S XOBHDLR=""
- ;
- ; -- # of chars to get on first read / read 11 for Broker initial read
- S XOBREAD=11
- ;
- ; -- get J2SE heartbeat rate for timeout plus network latency factor
- S XOBTO=$$GETRATE^XOBVLIB()+$$GETDELTA^XOBVLIB()
- ;
- ; -- get J2EE timeout value for app serv environment
- I $G(XOBSYS("ENV"))="j2ee" S XOBTO=$$GETASTO^XOBVLIB()
- ;
- ; -- set first read flag
- S XOBFIRST=1
- ;
- ; -- setup intake global
- S XOBROOT=$NA(^TMP("XOBVLL",$J))
- K @XOBROOT
- ;
- ; -- read from socket port
- U XOBPORT
- S XOBOK=$$READ^XOBVSKT(XOBROOT,.XOBREAD,.XOBTO,.XOBFIRST,.XOBSTOP,.XOBDATA,.XOBHDLR)
- ;
- ; -- timed out ; cleanup user and exit
- I 'XOBOK!(XOBSTOP) D G NXTCALLQ
- . I $G(DUZ) D CLEAN^XOBSCAV1
- . S XOBSTOP=1
- ;
- ; -- need null device
- ; * * *
- ;I '$D(XOBNULL) D ERROR(181002,$$EZBLD^DIALOG(181002),XOBPORT) S XOBSTOP=1 G NXTCALLQ
- I '$D(XOBNULL) D ERROR(181002,$$EZBLD^DIALOG(181002,$$EC^%ZOSV),XOBPORT) S XOBSTOP=1 G NXTCALLQ ;*6
- ; * * *
- ;
- ; -- call request manager
- S XOBOK=$$EN^XOBVRM(XOBROOT,.XOBDATA,.XOBHDLR)
- ; -- timestamp last time request made
- S XOBLASTR=$$NOW^XLFDT()
- ; -- cleanup intake global
- K @XOBROOT
- ;
- NXTCALLQ ; -- exit
- Q
- ;
- ; ----------------------------------------------------------------------------------
- ; System Error Handler
- ; ----------------------------------------------------------------------------------
- SYSERR ; -- send system error message
- ; -- If we get an error in the error handler just Halt
- S $ET="D APPERROR^%ZTER(""VistALink Error 181001"") HALT" ;*4
- D ERROR(181001,$$EZBLD^DIALOG(181001,$$EC^%ZOSV),XOBPORT) ; -- Get the error code
- Q
- ;
- ERROR(XOBEC,XOBMSG,XOBPORT) ; -- send error message
- N XOBDAT
- ;
- ; -- If we get an error in the error handler just Halt
- ;
- ; * * *
- ;S $ET="D APPERROR^%ZTER(""VistALink Error_$G(XOBDAT(""ERRORS"_",1,"_"""CODE"""_"),180000)"_") HALT" ;*4
- S $ET="D APPERROR^%ZTER(""VistALink Error ""_$G(XOBDAT(""ERRORS"""_",1,"_"""CODE"")"_",180000)) HALT" ;*6
- ; * * *
- ; -- set up error info
- S XOBDAT("MESSAGE TYPE")=3
- S XOBDAT("ERRORS",1,"CODE")=XOBEC
- S XOBDAT("ERRORS",1,"ERROR TYPE")="system"
- S XOBDAT("ERRORS",1,"FAULT STRING")="System Error"
- S XOBDAT("ERRORS",1,"CDATA")=1
- S XOBDAT("ERRORS",1,"MESSAGE",1)=XOBMSG
- ;
- ; -- if serious error, save error info, logout, and halt
- I (XOBMSG["<DSCON>")!(XOBMSG["<READ>")!(XOBMSG["<WRITE>")!(XOBMSG["<SYSTEM>")!(XOBMSG["READERR")!(XOBMSG["WRITERR")!(XOBMSG["SYSERR") D H
- . D APPERROR^%ZTER($S(XOBMSG["<DSCON>":$P(XOBMSG,":",2),1:"VistALink Error "_XOBEC)) ;*4
- . I $G(DUZ) D CLEAN^XOBSCAV1
- .Q
- ;
- ; -- send error back to client
- U XOBPORT
- D ERROR^XOBVLIB(.XOBDAT)
- ;
- ; -- just quit if no slots are available or logins are disabled
- I (XOBEC=181003)!(XOBEC=181004) Q
- ;
- ; -- need to make sure any locks are released since code aborted ungracefully
- L
- ;
- ; -- Save off the error
- D APPERROR^%ZTER($P(XOBMSG,": ",2)) ;*4
- ;
- ; -- go back to listening
- S $ET="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" DO KILL^XOBVLL G NXTCALLQ^XOBVLL",$EC=",U99,"
- Q
- ;
- KILL ; -- new VistALink variables and then do big KILL
- N XOBPORT,XOBSTOP,XOBNULL,XOBOS,XOBSYS,XOBHDLR,XOBOK,XOBLASTR,XOBCMREF
- D KILL^XUSCLEAN
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBVLL 5677 printed Feb 19, 2025@00:11:15 Page 2
- XOBVLL ;MJK/ALB - VistALink Listen and Spawn Code ; 07/27/2002 13:00
- +1 ;;1.6;VistALink;**4,6**;Apr 5,2017;Build 33
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ; ***deprecated*** tag ; Use START^XOBVTCP instead
- START(SOCKET) ; -- start listener
- +1 DO START^XOBVTCP(SOCKET)
- +2 QUIT
- +3 ;
- +4 ; ***deprecated*** tag ; Use UCX^XOBVTCP instead
- UCX ; -- VMS TCPIP (UCX) multi-thread entry point
- +1 ; -- Called from VistALink .com files
- +2 GOTO UCX^XOBVTCP
- +3 ;
- SPAWN ; -- spawned process
- +1 NEW X,XOBSTOP,XOBPORT,XOBHDLR,XOBLASTR,XOBCMREF
- +2 ;
- +3 SET XOBSTOP=0
- +4 SET XOBPORT=IO
- +5 SET U="^"
- +6 ;
- +7 ; -- initialize timestamp for last time request made (used for debugging)
- +8 SET XOBLASTR=0
- +9 ;
- +10 ; -- set error trap
- +11 ;Set up the error trap
- +12 ; * * *
- +13 ;S $ET="D APPERROR^%ZTER(""VistALink Error $P(XOBMSG,"": "",2 "") HALT" ;*4
- +14 ;*6
- SET $ETRAP="D APPERROR^%ZTER(""VistALink Error ""_$P(XOBMSG,"": "",2)) HALT"
- +15 ; * * *
- +16 ;
- +17 ; -- attempt to share the license; must have TCP port open first
- +18 USE XOBPORT
- IF $TEXT(SHARELIC^%ZOSV)'=""
- DO SHARELIC^%ZOSV(1)
- +19 ;
- +20 ; -- start RUM for VistALink Handler
- +21 DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1)
- +22 ;
- +23 ; -- cache/initialize startup request handlers
- +24 SET X=$$CACHE^XOBVRH(.XOBHDLR)
- +25 IF 'X
- DO RMERR^XOBVRM(184001,$PIECE(X,U,2))
- QUIT
- +26 ;
- +27 ; -- initialize tcp processing variables
- +28 DO INIT^XOBVSKT
- +29 ;
- +30 ; -- change job name if possible
- +31 DO SETNM^%ZOSV("VLink_"_$$CNV^XLFUTL($JOB,16))
- +32 ;
- +33 ; -- setup for Connection Mgr: get ref; kill data @ ref
- +34 SET XOBCMREF=$$GETREF^XOBUZAP1()
- +35 DO KILL^XOBUZAP0(XOBCMREF)
- +36 ;
- +37 ; -- loop until told to stop
- +38 FOR
- DO NXTCALL
- if XOBSTOP
- QUIT
- +39 ;
- +40 ; -- kill ^XTMP ref node
- +41 DO KILL^XOBUZAP0(XOBCMREF)
- +42 ;
- +43 ; -- final/clean tcp processing variables
- +44 DO FINAL^XOBVSKT
- +45 ;
- +46 ; -- stop RUM for VistALink Handler
- +47 DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,2)
- +48 ;
- +49 QUIT
- +50 ;
- NXTCALL ; -- do next call
- +1 NEW X,XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBOK,XOBRL,XOBDATA
- +2 ;
- +3 ; -- set up error trap
- +4 NEW $ESTACK
- SET $ETRAP="DO SYSERR^XOBVLL"
- +5 ;
- +6 ; -- setup environment variables
- +7 NEW DIQUIET
- SET DIQUIET=1
- +8 SET U="^"
- SET DTIME=$GET(DTIME,900)
- SET DT=$$DT^XLFDT()
- +9 ;
- +10 ; -- set ^XTMP for Connection Mgr usage if DUZ not 1st piece
- +11 IF '$$GETDUZ^XOBUZAP0(XOBCMREF)
- Begin DoDot:1
- +12 NEW XOBDUZ,XOBIP
- +13 SET XOBDUZ=$GET(XOBSYS("DUZ"),$GET(DUZ))
- +14 SET XOBIP=$GET(IO("IP"))
- +15 DO SETVI^XOBUZAP0(XOBCMREF,XOBDUZ,XOBIP,$$GETDESC^XOBUZAP1())
- End DoDot:1
- +16 ;
- +17 ; -- initialize 'current' request handler to empty string
- +18 SET XOBHDLR=""
- +19 ;
- +20 ; -- # of chars to get on first read / read 11 for Broker initial read
- +21 SET XOBREAD=11
- +22 ;
- +23 ; -- get J2SE heartbeat rate for timeout plus network latency factor
- +24 SET XOBTO=$$GETRATE^XOBVLIB()+$$GETDELTA^XOBVLIB()
- +25 ;
- +26 ; -- get J2EE timeout value for app serv environment
- +27 IF $GET(XOBSYS("ENV"))="j2ee"
- SET XOBTO=$$GETASTO^XOBVLIB()
- +28 ;
- +29 ; -- set first read flag
- +30 SET XOBFIRST=1
- +31 ;
- +32 ; -- setup intake global
- +33 SET XOBROOT=$NAME(^TMP("XOBVLL",$JOB))
- +34 KILL @XOBROOT
- +35 ;
- +36 ; -- read from socket port
- +37 USE XOBPORT
- +38 SET XOBOK=$$READ^XOBVSKT(XOBROOT,.XOBREAD,.XOBTO,.XOBFIRST,.XOBSTOP,.XOBDATA,.XOBHDLR)
- +39 ;
- +40 ; -- timed out ; cleanup user and exit
- +41 IF 'XOBOK!(XOBSTOP)
- Begin DoDot:1
- +42 IF $GET(DUZ)
- DO CLEAN^XOBSCAV1
- +43 SET XOBSTOP=1
- End DoDot:1
- GOTO NXTCALLQ
- +44 ;
- +45 ; -- need null device
- +46 ; * * *
- +47 ;I '$D(XOBNULL) D ERROR(181002,$$EZBLD^DIALOG(181002),XOBPORT) S XOBSTOP=1 G NXTCALLQ
- +48 ;*6
- IF '$DATA(XOBNULL)
- DO ERROR(181002,$$EZBLD^DIALOG(181002,$$EC^%ZOSV),XOBPORT)
- SET XOBSTOP=1
- GOTO NXTCALLQ
- +49 ; * * *
- +50 ;
- +51 ; -- call request manager
- +52 SET XOBOK=$$EN^XOBVRM(XOBROOT,.XOBDATA,.XOBHDLR)
- +53 ; -- timestamp last time request made
- +54 SET XOBLASTR=$$NOW^XLFDT()
- +55 ; -- cleanup intake global
- +56 KILL @XOBROOT
- +57 ;
- NXTCALLQ ; -- exit
- +1 QUIT
- +2 ;
- +3 ; ----------------------------------------------------------------------------------
- +4 ; System Error Handler
- +5 ; ----------------------------------------------------------------------------------
- SYSERR ; -- send system error message
- +1 ; -- If we get an error in the error handler just Halt
- +2 ;*4
- SET $ETRAP="D APPERROR^%ZTER(""VistALink Error 181001"") HALT"
- +3 ; -- Get the error code
- DO ERROR(181001,$$EZBLD^DIALOG(181001,$$EC^%ZOSV),XOBPORT)
- +4 QUIT
- +5 ;
- ERROR(XOBEC,XOBMSG,XOBPORT) ; -- send error message
- +1 NEW XOBDAT
- +2 ;
- +3 ; -- If we get an error in the error handler just Halt
- +4 ;
- +5 ; * * *
- +6 ;S $ET="D APPERROR^%ZTER(""VistALink Error_$G(XOBDAT(""ERRORS"_",1,"_"""CODE"""_"),180000)"_") HALT" ;*4
- +7 ;*6
- SET $ETRAP="D APPERROR^%ZTER(""VistALink Error ""_$G(XOBDAT(""ERRORS"""_",1,"_"""CODE"")"_",180000)) HALT"
- +8 ; * * *
- +9 ; -- set up error info
- +10 SET XOBDAT("MESSAGE TYPE")=3
- +11 SET XOBDAT("ERRORS",1,"CODE")=XOBEC
- +12 SET XOBDAT("ERRORS",1,"ERROR TYPE")="system"
- +13 SET XOBDAT("ERRORS",1,"FAULT STRING")="System Error"
- +14 SET XOBDAT("ERRORS",1,"CDATA")=1
- +15 SET XOBDAT("ERRORS",1,"MESSAGE",1)=XOBMSG
- +16 ;
- +17 ; -- if serious error, save error info, logout, and halt
- +18 IF (XOBMSG["<DSCON>")!(XOBMSG["<READ>")!(XOBMSG["<WRITE>")!(XOBMSG["<SYSTEM>")!(XOBMSG["READERR")!(XOBMSG["WRITERR")!(XOBMSG["SYSERR")
- Begin DoDot:1
- +19 ;*4
- DO APPERROR^%ZTER($SELECT(XOBMSG["<DSCON>":$PIECE(XOBMSG,":",2),1:"VistALink Error "_XOBEC))
- +20 IF $GET(DUZ)
- DO CLEAN^XOBSCAV1
- +21 QUIT
- End DoDot:1
- HANG
- +22 ;
- +23 ; -- send error back to client
- +24 USE XOBPORT
- +25 DO ERROR^XOBVLIB(.XOBDAT)
- +26 ;
- +27 ; -- just quit if no slots are available or logins are disabled
- +28 IF (XOBEC=181003)!(XOBEC=181004)
- QUIT
- +29 ;
- +30 ; -- need to make sure any locks are released since code aborted ungracefully
- +31 LOCK
- +32 ;
- +33 ; -- Save off the error
- +34 ;*4
- DO APPERROR^%ZTER($PIECE(XOBMSG,": ",2))
- +35 ;
- +36 ; -- go back to listening
- +37 SET $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" DO KILL^XOBVLL G NXTCALLQ^XOBVLL"
- SET $ECODE=",U99,"
- +38 QUIT
- +39 ;
- KILL ; -- new VistALink variables and then do big KILL
- +1 NEW XOBPORT,XOBSTOP,XOBNULL,XOBOS,XOBSYS,XOBHDLR,XOBOK,XOBLASTR,XOBCMREF
- +2 DO KILL^XUSCLEAN
- +3 QUIT
- +4 ;