XOBVSYSI ;; ld,mjk/alb - VistaLink Interface Implementation ; 07/27/2002 13:00
;;1.6;VistALink;;May 08, 2009;Build 15
;Per VHA directive 2004-038, this routine should not be modified.
CALLBACK(CB) ; -- init callbacks implementation
SET CB("STARTELEMENT")="ELEST^XOBVSYSI"
QUIT
;
; ------------------------------------------------------------------------
; RPC Server: Request Message XML SAX Parser Callbacks
; ------------------------------------------------------------------------
ELEST(ELE,ATR) ; -- element start event handler
IF ELE="VistaLink" DO QUIT
. SET XOBDATA("MODE")=$GET(ATR("mode"),"single call")
;
IF ELE="Request" DO QUIT
. SET XOBDATA("XOB SYSTEM","TYPE")=$GET(ATR("type"),"unknown")
. SET XOBDATA("XOB SYSTEM","ENV")=$$LOW^XLFSTR($GET(ATR("environment"),"j2se"))
;
QUIT
;
READER(XOBUF,XOBDATA) ; -- proprietary format reader implementation
QUIT
;
REQHDLR(XOBDATA) ; -- request handler implementation
NEW TYPE
SET TYPE=$GET(XOBDATA("XOB SYSTEM","TYPE"),"unknown")
;
; -- initialize socket partition request
IF TYPE="initializeSocket" DO INIT(.TYPE) GOTO REQHDLRQ
;
; -- set stop flag to close socket request
IF TYPE="closeSocket" DO CLOSE(.TYPE) GOTO REQHDLRQ
;
; -- cleanup partition request
IF TYPE="cleanupPartition" DO CLEANUP(.TYPE) GOTO REQHDLRQ
;
; -- heartbeat request
IF TYPE="heartbeat" DO HB(.TYPE) GOTO REQHDLRQ
;
; -- system info request
IF TYPE="systemInfo" DO SYSINFO(.TYPE) GOTO REQHDLRQ
;
; -- failure if processing get here
DO RESPONSE(.TYPE,"failure")
;
REQHDLRQ ;
QUIT
;
ENV ; -- set env variable
SET XOBSYS("ENV")=$GET(XOBDATA("XOB SYSTEM","ENV"))
QUIT
;
PSTANUM ; -- set primary station number
SET XOBSYS("PRIMARY STATION#")=$$TRUNCCH($$STA^XUAF4($$KSP^XUPARAM("INST")))
; note: AAC 200M is truncated to 200
QUIT
;
INIT(TYPE) ; -- handle initialize request
KILL XOBSYS
DO ENV
DO PSTANUM
;
IF "^j2se^j2ee^.net^"[(U_XOBSYS("ENV")_U) DO
. DO RESPONSE(.TYPE,"success",$$RATE()_$$JOB()_$$RASTO())
ELSE DO
. DO RESPONSE(.TYPE,"failure")
QUIT
;
CLOSE(TYPE) ; -- handle close socket request
SET XOBSTOP=1
DO RESPONSE(.TYPE,"success")
QUIT
;
CLEANUP(TYPE) ; -- handle cleanup partition request
; -- unlock any pending locks
LOCK
;
; -- clean ^TMP, ^UTILITY, ^XUTL
DO XUTL^XUSCLEAN
;
; -- restore DUZ to connector user
KILL DUZ
MERGE DUZ=XOBSYS("DUZ")
;
; -- clean symbol table
DO KILL^XOBVLL
;
DO RESPONSE(.TYPE,"success")
QUIT
;
DUZSV(DUZ) ; -- save initial DUZ info for session
IF $GET(XOBSYS("ENV"))="j2ee" DO
. KILL XOBSYS("DUZ")
. MERGE XOBSYS("DUZ")=DUZ
QUIT
;
HB(TYPE) ; -- handle heartbeat request
DO ENV
DO RESPONSE(.TYPE,"success",$$RATE())
QUIT
;
RATE() ; -- set up rate attribute for response
NEW XOBRATE
; -- get J2EE timeout value for app serv environment
IF $GET(XOBSYS("ENV"))="j2ee" DO
. SET XOBRATE=$$GETASTO^XOBVLIB()
ELSE DO
. SET XOBRATE=$$GETRATE^XOBVLIB()
QUIT " rate="""_XOBRATE_""""
;
JOB() ; -- set up $JOB attribute for response
QUIT " mJob="""_$JOB_""""
;
RASTO() ; -- set up ReAuthenticated Session TimeOut
QUIT " reAuthSessionTimeout="""_$$GETRASTO^XOBVLIB()_""""
;
RESPONSE(TYPE,STATUS,ATTRS) ; -- build xml response
; -- initialize
DO PRE^XOBVSKT
DO WRITE^XOBVSKT($$VLHDR^XOBVLIB(4))
DO WRITE^XOBVSKT("<Response type="""_$GET(TYPE)_""" status="""_$GET(STATUS)_""""_$GET(ATTRS,"")_" />")
DO WRITE^XOBVSKT($$ENVFTR^XOBVLIB())
; -- send eot and flush buffer
DO POST^XOBVSKT
QUIT
;
SYSINFO(TYPE) ; -- build system info response
NEW XOBINFO,XOBELE,XOBDEFLT,XOBINTRO,XOBI
;
; -- set up default value
SET XOBDEFLT="unknown"
;
; -- get system info array
DO GETSINFO(.XOBINFO)
;
; -- build <SystemInfo> element
SET XOBELE="<SystemInfo"
SET XOBELE=XOBELE_" vistalinkVersion="""_$GET(XOBINFO("version"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" vistalinkBuild="""_$GET(XOBINFO("build"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" appServerTimeout="""_$GET(XOBINFO("appServerTimeout"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" reAuthSessionTimeout="""_$GET(XOBINFO("reAuthSessionTimeout"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" uci="""_$GET(XOBINFO("uci"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" vol="""_$GET(XOBINFO("vol"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" boxVolume="""_$GET(XOBINFO("boxVolume"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" mVersion="""_$GET(XOBINFO("mVersion"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" operatingSystem="""_$GET(XOBINFO("operatingSystem"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" domainName="""_$GET(XOBINFO("domainName"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" vistaProduction="""_$GET(XOBINFO("vistaProduction"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" defaultInstitution="""_$GET(XOBINFO("defaultInstitution"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" cpName="""_$GET(XOBINFO("cpName"),XOBDEFLT)_""""
SET XOBELE=XOBELE_" />"
;
SET XOBINTRO=$GET(XOBINFO("introductoryText"))
;
; -- build and send complete message
DO PRE^XOBVSKT
DO WRITE^XOBVSKT($$VLHDR^XOBVLIB(4))
DO WRITE^XOBVSKT("<Response type="""_$GET(TYPE)_""" status=""success"" >")
DO WRITE^XOBVSKT(XOBELE)
FOR XOBI=1:1 QUIT:'$DATA(XOBINFO("introductoryText",XOBI)) DO
. DO WRITE^XOBVSKT(XOBINFO("introductoryText",XOBI))
DO WRITE^XOBVSKT("</Response>")
DO WRITE^XOBVSKT($$ENVFTR^XOBVLIB())
DO POST^XOBVSKT
;
QUIT
;
GETSINFO(XOBINFO) ; -- gather system info into array
NEW X,Y
;
; -- get version
SET XOBINFO("version")=$PIECE($TEXT(XOBVSYSI+1),";",3)
;
; -- get build number
SET XOBINFO("build")=$PIECE($TEXT(XOBVSYSI+1),";",7)
;
; -- get application server connection timeout
SET XOBINFO("appServerTimeout")=$$GETASTO^XOBVLIB()
;
; -- get reauthentication session timeout
SET XOBINFO("reAuthSessionTimeout")=$$GETRASTO^XOBVLIB()
;
; -- get basic M environment information
SET Y=""
DO GETENV^%ZOSV
;
; -- get uci
SET XOBINFO("uci")=$PIECE(Y,U,1)
;
; -- get vol
SET XOBINFO("vol")=$PIECE(Y,U,2)
;
; -- get box volume
SET XOBINFO("boxVolume")=$PIECE(Y,U,4)
;
; -- get M version (full name)
SET XOBINFO("mVersion")=$$SYMENC^MXMLUTL($$VERSION^%ZOSV(1))
;
; -- get operating system
SET XOBINFO("operatingSystem")=$$SYMENC^MXMLUTL($$SYSOS^XOBVLIB(XOBOS))
;
; -- get domain name
SET XOBINFO("domainName")=$$SYMENC^MXMLUTL($$KSP^XUPARAM("WHERE"))
;
; -- production or test
SET XOBINFO("vistaProduction")=$S($$PROD^XUPROD(0):"true",1:"false")
;
; -- default institution
SET XOBINFO("defaultInstitution")=$$SYMENC^MXMLUTL($$STA^XUAF4($$KSP^XUPARAM("INST"))_"/"_$$NAME^XUAF4($$KSP^XUPARAM("INST")))
;
; -- get intro text
D GETINTRO^XOBSCAV2("XOBINFO(""introductoryText"")",1)
;
; -- get c/p username
SET XOBINFO("cpName")=$$NAME^XUSER(DUZ)
;
QUIT
;
RPC(XOBY) ;
NEW XOBX,XOBLINE,XOBARR
D GETSINFO(.XOBARR)
SET XOBLINE=0
S XOBX="" F S XOBX=$O(XOBARR(XOBX)) Q:XOBX']"" D
. SET XOBLINE=XOBLINE+1
. SET XOBY(XOBLINE)=XOBX_"~"_XOBARR(XOBX)
QUIT
;
TRUNCCH(XOBSTR) ; truncate before first non-numeric char
NEW XOBI,XOBSTOP,XOBSTR1
SET XOBSTOP=0,XOBSTR1=""
FOR XOBI=1:1:$L(XOBSTR) QUIT:XOBSTOP DO
. IF "0123456789"'[$E(XOBSTR,XOBI) SET XOBSTOP=1 QUIT
. SET XOBSTR1=XOBSTR1_$E(XOBSTR,XOBI)
QUIT XOBSTR1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBVSYSI 7342 printed Apr 09, 2024@21:47:02 Page 2
XOBVSYSI ;; ld,mjk/alb - VistaLink Interface Implementation ; 07/27/2002 13:00
+1 ;;1.6;VistALink;;May 08, 2009;Build 15
+2 ;Per VHA directive 2004-038, this routine should not be modified.
CALLBACK(CB) ; -- init callbacks implementation
+1 SET CB("STARTELEMENT")="ELEST^XOBVSYSI"
+2 QUIT
+3 ;
+4 ; ------------------------------------------------------------------------
+5 ; RPC Server: Request Message XML SAX Parser Callbacks
+6 ; ------------------------------------------------------------------------
ELEST(ELE,ATR) ; -- element start event handler
+1 IF ELE="VistaLink"
Begin DoDot:1
+2 SET XOBDATA("MODE")=$GET(ATR("mode"),"single call")
End DoDot:1
QUIT
+3 ;
+4 IF ELE="Request"
Begin DoDot:1
+5 SET XOBDATA("XOB SYSTEM","TYPE")=$GET(ATR("type"),"unknown")
+6 SET XOBDATA("XOB SYSTEM","ENV")=$$LOW^XLFSTR($GET(ATR("environment"),"j2se"))
End DoDot:1
QUIT
+7 ;
+8 QUIT
+9 ;
READER(XOBUF,XOBDATA) ; -- proprietary format reader implementation
+1 QUIT
+2 ;
REQHDLR(XOBDATA) ; -- request handler implementation
+1 NEW TYPE
+2 SET TYPE=$GET(XOBDATA("XOB SYSTEM","TYPE"),"unknown")
+3 ;
+4 ; -- initialize socket partition request
+5 IF TYPE="initializeSocket"
DO INIT(.TYPE)
GOTO REQHDLRQ
+6 ;
+7 ; -- set stop flag to close socket request
+8 IF TYPE="closeSocket"
DO CLOSE(.TYPE)
GOTO REQHDLRQ
+9 ;
+10 ; -- cleanup partition request
+11 IF TYPE="cleanupPartition"
DO CLEANUP(.TYPE)
GOTO REQHDLRQ
+12 ;
+13 ; -- heartbeat request
+14 IF TYPE="heartbeat"
DO HB(.TYPE)
GOTO REQHDLRQ
+15 ;
+16 ; -- system info request
+17 IF TYPE="systemInfo"
DO SYSINFO(.TYPE)
GOTO REQHDLRQ
+18 ;
+19 ; -- failure if processing get here
+20 DO RESPONSE(.TYPE,"failure")
+21 ;
REQHDLRQ ;
+1 QUIT
+2 ;
ENV ; -- set env variable
+1 SET XOBSYS("ENV")=$GET(XOBDATA("XOB SYSTEM","ENV"))
+2 QUIT
+3 ;
PSTANUM ; -- set primary station number
+1 SET XOBSYS("PRIMARY STATION#")=$$TRUNCCH($$STA^XUAF4($$KSP^XUPARAM("INST")))
+2 ; note: AAC 200M is truncated to 200
+3 QUIT
+4 ;
INIT(TYPE) ; -- handle initialize request
+1 KILL XOBSYS
+2 DO ENV
+3 DO PSTANUM
+4 ;
+5 IF "^j2se^j2ee^.net^"[(U_XOBSYS("ENV")_U)
Begin DoDot:1
+6 DO RESPONSE(.TYPE,"success",$$RATE()_$$JOB()_$$RASTO())
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 DO RESPONSE(.TYPE,"failure")
End DoDot:1
+9 QUIT
+10 ;
CLOSE(TYPE) ; -- handle close socket request
+1 SET XOBSTOP=1
+2 DO RESPONSE(.TYPE,"success")
+3 QUIT
+4 ;
CLEANUP(TYPE) ; -- handle cleanup partition request
+1 ; -- unlock any pending locks
+2 LOCK
+3 ;
+4 ; -- clean ^TMP, ^UTILITY, ^XUTL
+5 DO XUTL^XUSCLEAN
+6 ;
+7 ; -- restore DUZ to connector user
+8 KILL DUZ
+9 MERGE DUZ=XOBSYS("DUZ")
+10 ;
+11 ; -- clean symbol table
+12 DO KILL^XOBVLL
+13 ;
+14 DO RESPONSE(.TYPE,"success")
+15 QUIT
+16 ;
DUZSV(DUZ) ; -- save initial DUZ info for session
+1 IF $GET(XOBSYS("ENV"))="j2ee"
Begin DoDot:1
+2 KILL XOBSYS("DUZ")
+3 MERGE XOBSYS("DUZ")=DUZ
End DoDot:1
+4 QUIT
+5 ;
HB(TYPE) ; -- handle heartbeat request
+1 DO ENV
+2 DO RESPONSE(.TYPE,"success",$$RATE())
+3 QUIT
+4 ;
RATE() ; -- set up rate attribute for response
+1 NEW XOBRATE
+2 ; -- get J2EE timeout value for app serv environment
+3 IF $GET(XOBSYS("ENV"))="j2ee"
Begin DoDot:1
+4 SET XOBRATE=$$GETASTO^XOBVLIB()
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET XOBRATE=$$GETRATE^XOBVLIB()
End DoDot:1
+7 QUIT " rate="""_XOBRATE_""""
+8 ;
JOB() ; -- set up $JOB attribute for response
+1 QUIT " mJob="""_$JOB_""""
+2 ;
RASTO() ; -- set up ReAuthenticated Session TimeOut
+1 QUIT " reAuthSessionTimeout="""_$$GETRASTO^XOBVLIB()_""""
+2 ;
RESPONSE(TYPE,STATUS,ATTRS) ; -- build xml response
+1 ; -- initialize
+2 DO PRE^XOBVSKT
+3 DO WRITE^XOBVSKT($$VLHDR^XOBVLIB(4))
+4 DO WRITE^XOBVSKT("<Response type="""_$GET(TYPE)_""" status="""_$GET(STATUS)_""""_$GET(ATTRS,"")_" />")
+5 DO WRITE^XOBVSKT($$ENVFTR^XOBVLIB())
+6 ; -- send eot and flush buffer
+7 DO POST^XOBVSKT
+8 QUIT
+9 ;
SYSINFO(TYPE) ; -- build system info response
+1 NEW XOBINFO,XOBELE,XOBDEFLT,XOBINTRO,XOBI
+2 ;
+3 ; -- set up default value
+4 SET XOBDEFLT="unknown"
+5 ;
+6 ; -- get system info array
+7 DO GETSINFO(.XOBINFO)
+8 ;
+9 ; -- build <SystemInfo> element
+10 SET XOBELE="<SystemInfo"
+11 SET XOBELE=XOBELE_" vistalinkVersion="""_$GET(XOBINFO("version"),XOBDEFLT)_""""
+12 SET XOBELE=XOBELE_" vistalinkBuild="""_$GET(XOBINFO("build"),XOBDEFLT)_""""
+13 SET XOBELE=XOBELE_" appServerTimeout="""_$GET(XOBINFO("appServerTimeout"),XOBDEFLT)_""""
+14 SET XOBELE=XOBELE_" reAuthSessionTimeout="""_$GET(XOBINFO("reAuthSessionTimeout"),XOBDEFLT)_""""
+15 SET XOBELE=XOBELE_" uci="""_$GET(XOBINFO("uci"),XOBDEFLT)_""""
+16 SET XOBELE=XOBELE_" vol="""_$GET(XOBINFO("vol"),XOBDEFLT)_""""
+17 SET XOBELE=XOBELE_" boxVolume="""_$GET(XOBINFO("boxVolume"),XOBDEFLT)_""""
+18 SET XOBELE=XOBELE_" mVersion="""_$GET(XOBINFO("mVersion"),XOBDEFLT)_""""
+19 SET XOBELE=XOBELE_" operatingSystem="""_$GET(XOBINFO("operatingSystem"),XOBDEFLT)_""""
+20 SET XOBELE=XOBELE_" domainName="""_$GET(XOBINFO("domainName"),XOBDEFLT)_""""
+21 SET XOBELE=XOBELE_" vistaProduction="""_$GET(XOBINFO("vistaProduction"),XOBDEFLT)_""""
+22 SET XOBELE=XOBELE_" defaultInstitution="""_$GET(XOBINFO("defaultInstitution"),XOBDEFLT)_""""
+23 SET XOBELE=XOBELE_" cpName="""_$GET(XOBINFO("cpName"),XOBDEFLT)_""""
+24 SET XOBELE=XOBELE_" />"
+25 ;
+26 SET XOBINTRO=$GET(XOBINFO("introductoryText"))
+27 ;
+28 ; -- build and send complete message
+29 DO PRE^XOBVSKT
+30 DO WRITE^XOBVSKT($$VLHDR^XOBVLIB(4))
+31 DO WRITE^XOBVSKT("<Response type="""_$GET(TYPE)_""" status=""success"" >")
+32 DO WRITE^XOBVSKT(XOBELE)
+33 FOR XOBI=1:1
if '$DATA(XOBINFO("introductoryText",XOBI))
QUIT
Begin DoDot:1
+34 DO WRITE^XOBVSKT(XOBINFO("introductoryText",XOBI))
End DoDot:1
+35 DO WRITE^XOBVSKT("</Response>")
+36 DO WRITE^XOBVSKT($$ENVFTR^XOBVLIB())
+37 DO POST^XOBVSKT
+38 ;
+39 QUIT
+40 ;
GETSINFO(XOBINFO) ; -- gather system info into array
+1 NEW X,Y
+2 ;
+3 ; -- get version
+4 SET XOBINFO("version")=$PIECE($TEXT(XOBVSYSI+1),";",3)
+5 ;
+6 ; -- get build number
+7 SET XOBINFO("build")=$PIECE($TEXT(XOBVSYSI+1),";",7)
+8 ;
+9 ; -- get application server connection timeout
+10 SET XOBINFO("appServerTimeout")=$$GETASTO^XOBVLIB()
+11 ;
+12 ; -- get reauthentication session timeout
+13 SET XOBINFO("reAuthSessionTimeout")=$$GETRASTO^XOBVLIB()
+14 ;
+15 ; -- get basic M environment information
+16 SET Y=""
+17 DO GETENV^%ZOSV
+18 ;
+19 ; -- get uci
+20 SET XOBINFO("uci")=$PIECE(Y,U,1)
+21 ;
+22 ; -- get vol
+23 SET XOBINFO("vol")=$PIECE(Y,U,2)
+24 ;
+25 ; -- get box volume
+26 SET XOBINFO("boxVolume")=$PIECE(Y,U,4)
+27 ;
+28 ; -- get M version (full name)
+29 SET XOBINFO("mVersion")=$$SYMENC^MXMLUTL($$VERSION^%ZOSV(1))
+30 ;
+31 ; -- get operating system
+32 SET XOBINFO("operatingSystem")=$$SYMENC^MXMLUTL($$SYSOS^XOBVLIB(XOBOS))
+33 ;
+34 ; -- get domain name
+35 SET XOBINFO("domainName")=$$SYMENC^MXMLUTL($$KSP^XUPARAM("WHERE"))
+36 ;
+37 ; -- production or test
+38 SET XOBINFO("vistaProduction")=$SELECT($$PROD^XUPROD(0):"true",1:"false")
+39 ;
+40 ; -- default institution
+41 SET XOBINFO("defaultInstitution")=$$SYMENC^MXMLUTL($$STA^XUAF4($$KSP^XUPARAM("INST"))_"/"_$$NAME^XUAF4($$KSP^XUPARAM("INST")))
+42 ;
+43 ; -- get intro text
+44 DO GETINTRO^XOBSCAV2("XOBINFO(""introductoryText"")",1)
+45 ;
+46 ; -- get c/p username
+47 SET XOBINFO("cpName")=$$NAME^XUSER(DUZ)
+48 ;
+49 QUIT
+50 ;
RPC(XOBY) ;
+1 NEW XOBX,XOBLINE,XOBARR
+2 DO GETSINFO(.XOBARR)
+3 SET XOBLINE=0
+4 SET XOBX=""
FOR
SET XOBX=$ORDER(XOBARR(XOBX))
if XOBX']""
QUIT
Begin DoDot:1
+5 SET XOBLINE=XOBLINE+1
+6 SET XOBY(XOBLINE)=XOBX_"~"_XOBARR(XOBX)
End DoDot:1
+7 QUIT
+8 ;
TRUNCCH(XOBSTR) ; truncate before first non-numeric char
+1 NEW XOBI,XOBSTOP,XOBSTR1
+2 SET XOBSTOP=0
SET XOBSTR1=""
+3 FOR XOBI=1:1:$LENGTH(XOBSTR)
if XOBSTOP
QUIT
Begin DoDot:1
+4 IF "0123456789"'[$EXTRACT(XOBSTR,XOBI)
SET XOBSTOP=1
QUIT
+5 SET XOBSTR1=XOBSTR1_$EXTRACT(XOBSTR,XOBI)
End DoDot:1
+6 QUIT XOBSTR1
