XOBVRPC ;; mjk/alb - VistaLInk RPC Server Listener Code ; 07/27/2002 13:00
;;1.5;VistALink;;Sep 09, 2005
;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
;
QUIT
;
; ------------------------------------------------------------------------
; RPC Server: Message Request Handler
; ------------------------------------------------------------------------
;
EN(XOBDATA) ; -- handle parsed messages request
NEW DX,DY,RPC0,RPCNAME,RPCIEN,TAG,ROU,METHSIG,XOBERR,XOBR,XOBSEC,XOBWRAP,XOBPTYPE,XRTN,XOBRA,XOBVER
;
IF $GET(XOBDATA("XOB RPC","RPC NAME"))="" DO GOTO ENQ
. DO ERROR(182001,"[No RPC]","")
;
SET RPCNAME=XOBDATA("XOB RPC","RPC NAME")
;
IF $DATA(^XWB(8994,"B",RPCNAME))=0 DO GOTO ENQ
. DO ERROR(182002,RPCNAME,RPCNAME)
;
IF $DATA(^XWB(8994,"B",RPCNAME))=10 SET RPCIEN=+$ORDER(^XWB(8994,"B",RPCNAME,""))
;
; -- get zero node
SET RPC0=$GET(^XWB(8994,RPCIEN,0))
;
; -- make sure there is data on node
IF RPC0="" DO GOTO ENQ
. DO ERROR(182003,RPCNAME,RPCNAME)
;
; -- make sure x-ref is not corrupt and found the wrong entry
IF RPCNAME'=$PIECE(RPC0,U) DO GOTO ENQ
. NEW PARAMS SET PARAMS(1)=RPCNAME,PARAMS(2)=$PIECE(RPC0,U)
. DO ERROR(182008,RPCNAME,.PARAMS)
;
; -- check inactive flag
IF $PIECE(RPC0,U,6)=1!($PIECE(RPC0,U,6)=2) DO GOTO ENQ
. DO ERROR(182004,RPCNAME,RPCNAME)
;
; -- if not already performed, check version, environment and set re-auth check flag
SET XOBERR=$SELECT($DATA(XOBSYS("RPC REAUTH")):0,1:$$VER())
IF XOBERR DO GOTO ENQ
. DO ERROR(XOBERR,RPCNAME)
;
; -- reauthentication checks
SET XOBERR=0
IF +$GET(XOBSYS("RPC REAUTH")) DO GOTO:XOBERR ENQ
. ;
. ; -- reauthenticate user based on type (i.e. DUZ,AV,VPID,CCOW,APPPROXY)
. SET XOBERR=$$SETUPDUZ^XOBSRA()
. IF XOBERR DO ERROR(XOBERR,RPCNAME) QUIT
. ;
. ; -- if application proxy user, check if allowed to run RPC
. IF $$UP^XLFSTR(XOBDATA("XOB RPC","SECURITY","TYPE"))="APPPROXY",'$$RPC^XUSAP($GET(RPCIEN)) DO QUIT
.. SET XOBERR=182010
.. DO ERROR(XOBERR,RPCNAME,RPCNAME)
;
; -- set context
SET XOBSEC=$$CRCONTXT^XOBSCAV($GET(XOBDATA("XOB RPC","RPC CONTEXT")))
IF '+XOBSEC DO GOTO ENQ
. DO ERROR(182005,RPCNAME,XOBSEC)
;
; -- check if appropriate context created
SET XOBSEC=$$CHKCTXT^XOBSCAV(RPCNAME)
IF '+XOBSEC DO GOTO ENQ
. DO ERROR(182006,RPCNAME,XOBSEC)
;
; -- setup timeout info
SET XOBDATA("XOB RPC","TIMED OUT")=0
SET XOBDATA("XOB RPC","START")=$HOROLOG
;
; -- setup info needed for RPC execution
SET TAG=$PIECE(RPC0,U,2)
SET ROU=$PIECE(RPC0,U,3)
SET XOBPTYPE=$PIECE(RPC0,U,4)
SET XOBWRAP=$PIECE(RPC0,U,8)
SET XOBVER=$$GETVER^XOBVRPCX()
;
; -- build method signature
SET METHSIG=TAG_"^"_ROU_"(.XOBR"_$GET(XOBDATA("XOB RPC","PARAMS"))_")"
;
; -- start RTL
DO:$DATA(XRTL) T0^%ZOSV
;
; -- use null device in case of writing during RPC execution
USE XOBNULL
;
; -- start RUM for RPC Name
DO LOGRSRC^%ZOSV(RPCNAME,2,1)
;
; -- execute RPC
DO CALLRPC(.XOBPTYPE,.XOBWRAP,.XOBVER,METHSIG)
;
; -- re-start RUM for VistaLink Handler
DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1)
;
; -- stop RTL
SET:$DATA(XRT0) XRTN=RPCNAME DO:$DATA(XRT0) T1^%ZOSV
;
; -- empty write buffer of null device
USE XOBNULL SET DX=0,DY=0 XECUTE ^%ZOSF("XY")
;
; -- reset to use tcp port device to send results
USE XOBPORT
;
; -- check for RPC processing timeout
IF $$TOCHK^XOBVLIB() DO GOTO ENQ
. NEW PARAMS SET PARAMS(1)=RPCNAME,PARAMS(2)=$$GETTO^XOBVLIB()
. DO ERROR(182007,RPCNAME,.PARAMS)
;
; -- send results
DO SEND(.XOBR)
;
ENQ ; -- end message handler
DO CLEAN
QUIT
;
CALLRPC(XWBPTYPE,XWBWRAP,XWBAPVER,METHSIG) ;-- execute RPC (use Broker RPC return type & wrap flag if there)
DO @METHSIG
QUIT
;
CLEAN ; -- clean up message handler environment
NEW POS
; -- kill parameters
SET POS=0
FOR SET POS=$ORDER(XOBDATA("XOB RPC","PARAMS",POS)) QUIT:'POS KILL @XOBDATA("XOB RPC","PARAMS",POS)
QUIT
;
SEND(XOBR) ; -- stream rpc data to client
NEW XOBFMT,XOBFILL
;
SET XOBFMT=$$GETFMT()
; -- prepare socket for writing
DO PRE^XOBVSKT
; -- initialize XML headers
DO WRITE^XOBVSKT($$VLHDR^XOBVLIB(1))
; -- start response
DO WRITE^XOBVSKT("<Response type="""_XOBFMT_""" ><![CDATA[")
; -- results
DO PROCESS
; -- finalize
DO WRITE^XOBVSKT("]]></Response>"_$$ENVFTR^XOBVLIB())
; -- send eot and flush buffer
DO POST^XOBVSKT
;
QUIT
;
DOCTYPE ;
DO WRITE^XOBVSKT("<!DOCTYPE vistalink [<!ELEMENT vistalink (results) ><!ELEMENT results (#PCDATA)><!ATTLIST vistalink type CDATA ""Gov.VA.Med.RPC.Response"" ><!ATTLIST results type (array|string) >]>")
QUIT
;
GETFMT() ; -- determine response format type
IF XOBPTYPE=1!(XOBPTYPE=5)!(XOBPTYPE=6) QUIT "string"
IF XOBPTYPE=2 QUIT "array"
;
QUIT $SELECT(XOBWRAP:"array",1:"string")
;
PROCESS ; -- send the real results
NEW I,T,D
; -- single value
IF XOBPTYPE=1 SET XOBR=$GET(XOBR) DO WRITE^XOBVSKT(XOBR) QUIT
; -- table delimited by CR+LF
IF XOBPTYPE=2 DO QUIT
. SET I="" FOR SET I=$ORDER(XOBR(I)) QUIT:I="" DO WRITE^XOBVSKT(XOBR(I)),WRITE^XOBVSKT($CHAR(10))
; -- word processing
IF XOBPTYPE=3 DO QUIT
. SET I="" FOR SET I=$ORDER(XOBR(I)) QUIT:I="" DO WRITE^XOBVSKT(XOBR(I)) DO:XOBWRAP WRITE^XOBVSKT($CHAR(10))
; -- global array
IF XOBPTYPE=4 DO QUIT
. IF $EXTRACT($GET(XOBR))'="^" QUIT
. SET I=$GET(XOBR) QUIT:I="" SET T=$EXTRACT(I,1,$LENGTH(I)-1)
. ;Only send root node if non-null.
. IF $DATA(@I)>10 SET D=@I IF $LENGTH(D) DO WRITE^XOBVSKT(D),WRITE^XOBVSKT($CHAR(10)):XOBWRAP&(D'=$CHAR(10))
. FOR SET I=$QUERY(@I) QUIT:I=""!(I'[T) SET D=@I DO WRITE^XOBVSKT(D),WRITE^XOBVSKT($CHAR(10)):XOBWRAP&(D'=$CHAR(10))
. IF $DATA(@XOBR) KILL @XOBR
; -- global instance
IF XOBPTYPE=5 DO QUIT
. IF $EXTRACT($GET(XOBR))'="^" QUIT
. SET XOBR=$GET(@XOBR) DO WRITE^XOBVSKT(XOBR)
; -- variable length records only good upto 255 char)
IF XOBPTYPE=6 DO
. SET I="" FOR SET I=$ORDER(XOBR(I)) QUIT:I="" DO WRITE^XOBVSKT($CHAR($LENGTH(XOBR(I)))),WRITE^XOBVSKT(XOBR(I))
QUIT
;
ERROR(CODE,RPCNAME,PARAMS) ; -- send rpc application error
; -- if parameters are passed as in CODE (where CODE = code^param1^param2^...)
; -- parse CODE and put parameters into PARAMS array.
IF CODE[U,$DATA(PARAMS)=0 DO
. KILL PARAMS
. FOR XOBI=2:1:$LENGTH(XOBERR,U) SET PARAMS(XOBI-1)=$PIECE(XOBERR,U,XOBI)
. SET CODE=+CODE
;
SET XOBDAT("MESSAGE TYPE")=2
SET XOBDAT("ERRORS",1,"FAULT STRING")="Internal Application Error"
SET XOBDAT("ERRORS",1,"FAULT ACTOR")=RPCNAME
SET XOBDAT("ERRORS",1,"CODE")=CODE
SET XOBDAT("ERRORS",1,"ERROR TYPE")=RPCNAME
SET XOBDAT("ERRORS",1,"CDATA")=0
SET XOBDAT("ERRORS",1,"MESSAGE",1)=$$EZBLD^DIALOG(CODE,.PARAMS)
DO ERROR^XOBVLIB(.XOBDAT)
;
; -- save info in error system
;DO ^%ZTER
QUIT
;
VER() ; -- check version and if re-authentication check is needed
; -- IMPORTANT: This tag needs updating for version numbers for each target release.
; -- This call needs only be called once per connection.
;
NEW XOBERR,CV,SV,ENV
;
KILL XOBSYS("RPC REAUTH")
;
SET XOBERR=0
; -- default re-auh flag to true
SET XOBRA=1
; -- client version
SET CV=XOBDATA("XOB RPC","RPC HANDLER VERSION")
; -- current server version
SET SV="1.5"
; -- client environment
SET ENV=XOBSYS("ENV")
;
; -- if client version is not supported then return error
IF ("^1.0^1.5^")'[(U_CV_U) DO GOTO VERQ
. SET XOBERR=182009_U_CV_U_SV_U_"Client version not supported"
;
; -- if client environment is not supported then return error
IF ("^j2se^j2ee^.net^")'[(U_ENV_U) DO GOTO VERQ
. SET XOBERR=182009_U_CV_U_SV_U_"Client environment ("_$$UP^XLFSTR(ENV)_") not supported"
;
; -- if client/server environment then ok
IF ("^j2se^.net^")[(U_ENV_U) SET XOBRA=0 GOTO VERQ
;
; -- if client version is "1.0" and client is j2ee then return error
IF CV="1.0",ENV="j2ee" DO GOTO VERQ
. SET XOBERR=182009_U_CV_U_SV_U_"Client RPC version does not support "_$$UP^XLFSTR(ENV)
;
; -- if client version supports j2ee and client is j2ee then ok (default)
;IF ENV="j2ee" GOTO VERQ
;
VERQ ;
IF 'XOBERR SET XOBSYS("RPC REAUTH")=XOBRA
QUIT XOBERR
;
XOBVRPC ;; mjk/alb - VistaLInk RPC Server Listener Code ; 07/27/2002 13:00
+1 ;;1.5;VistALink;;Sep 09, 2005
+2 ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
+3 ;
+4 QUIT
+5 ;
+6 ; ------------------------------------------------------------------------
+7 ; RPC Server: Message Request Handler
+8 ; ------------------------------------------------------------------------
+9 ;
EN(XOBDATA) ; -- handle parsed messages request
+1 NEW DX,DY,RPC0,RPCNAME,RPCIEN,TAG,ROU,METHSIG,XOBERR,XOBR,XOBSEC,XOBWRAP,XOBPTYPE,XRTN,XOBRA,XOBVER
+2 ;
+3 IF $GET(XOBDATA("XOB RPC","RPC NAME"))=""
Begin DoDot:1
+4 DO ERROR(182001,"[No RPC]","")
End DoDot:1
GOTO ENQ
+5 ;
+6 SET RPCNAME=XOBDATA("XOB RPC","RPC NAME")
+7 ;
+8 IF $DATA(^XWB(8994,"B",RPCNAME))=0
Begin DoDot:1
+9 DO ERROR(182002,RPCNAME,RPCNAME)
End DoDot:1
GOTO ENQ
+10 ;
+11 IF $DATA(^XWB(8994,"B",RPCNAME))=10
SET RPCIEN=+$ORDER(^XWB(8994,"B",RPCNAME,""))
+12 ;
+13 ; -- get zero node
+14 SET RPC0=$GET(^XWB(8994,RPCIEN,0))
+15 ;
+16 ; -- make sure there is data on node
+17 IF RPC0=""
Begin DoDot:1
+18 DO ERROR(182003,RPCNAME,RPCNAME)
End DoDot:1
GOTO ENQ
+19 ;
+20 ; -- make sure x-ref is not corrupt and found the wrong entry
+21 IF RPCNAME'=$PIECE(RPC0,U)
Begin DoDot:1
+22 NEW PARAMS
SET PARAMS(1)=RPCNAME
SET PARAMS(2)=$PIECE(RPC0,U)
+23 DO ERROR(182008,RPCNAME,.PARAMS)
End DoDot:1
GOTO ENQ
+24 ;
+25 ; -- check inactive flag
+26 IF $PIECE(RPC0,U,6)=1!($PIECE(RPC0,U,6)=2)
Begin DoDot:1
+27 DO ERROR(182004,RPCNAME,RPCNAME)
End DoDot:1
GOTO ENQ
+28 ;
+29 ; -- if not already performed, check version, environment and set re-auth check flag
+30 SET XOBERR=$SELECT($DATA(XOBSYS("RPC REAUTH")):0,1:$$VER())
+31 IF XOBERR
Begin DoDot:1
+32 DO ERROR(XOBERR,RPCNAME)
End DoDot:1
GOTO ENQ
+33 ;
+34 ; -- reauthentication checks
+35 SET XOBERR=0
+36 IF +$GET(XOBSYS("RPC REAUTH"))
Begin DoDot:1
+37 ;
+38 ; -- reauthenticate user based on type (i.e. DUZ,AV,VPID,CCOW,APPPROXY)
+39 SET XOBERR=$$SETUPDUZ^XOBSRA()
+40 IF XOBERR
DO ERROR(XOBERR,RPCNAME)
QUIT
+41 ;
+42 ; -- if application proxy user, check if allowed to run RPC
+43 IF $$UP^XLFSTR(XOBDATA("XOB RPC","SECURITY","TYPE"))="APPPROXY"
IF '$$RPC^XUSAP($GET(RPCIEN))
Begin DoDot:2
+44 SET XOBERR=182010
+45 DO ERROR(XOBERR,RPCNAME,RPCNAME)
End DoDot:2
QUIT
End DoDot:1
IF XOBERR
GOTO ENQ
+46 ;
+47 ; -- set context
+48 SET XOBSEC=$$CRCONTXT^XOBSCAV($GET(XOBDATA("XOB RPC","RPC CONTEXT")))
+49 IF '+XOBSEC
Begin DoDot:1
+50 DO ERROR(182005,RPCNAME,XOBSEC)
End DoDot:1
GOTO ENQ
+51 ;
+52 ; -- check if appropriate context created
+53 SET XOBSEC=$$CHKCTXT^XOBSCAV(RPCNAME)
+54 IF '+XOBSEC
Begin DoDot:1
+55 DO ERROR(182006,RPCNAME,XOBSEC)
End DoDot:1
GOTO ENQ
+56 ;
+57 ; -- setup timeout info
+58 SET XOBDATA("XOB RPC","TIMED OUT")=0
+59 SET XOBDATA("XOB RPC","START")=$HOROLOG
+60 ;
+61 ; -- setup info needed for RPC execution
+62 SET TAG=$PIECE(RPC0,U,2)
+63 SET ROU=$PIECE(RPC0,U,3)
+64 SET XOBPTYPE=$PIECE(RPC0,U,4)
+65 SET XOBWRAP=$PIECE(RPC0,U,8)
+66 SET XOBVER=$$GETVER^XOBVRPCX()
+67 ;
+68 ; -- build method signature
+69 SET METHSIG=TAG_"^"_ROU_"(.XOBR"_$GET(XOBDATA("XOB RPC","PARAMS"))_")"
+70 ;
+71 ; -- start RTL
+72 IF $DATA(XRTL)
DO T0^%ZOSV
+73 ;
+74 ; -- use null device in case of writing during RPC execution
+75 USE XOBNULL
+76 ;
+77 ; -- start RUM for RPC Name
+78 DO LOGRSRC^%ZOSV(RPCNAME,2,1)
+79 ;
+80 ; -- execute RPC
+81 DO CALLRPC(.XOBPTYPE,.XOBWRAP,.XOBVER,METHSIG)
+82 ;
+83 ; -- re-start RUM for VistaLink Handler
+84 DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1)
+85 ;
+86 ; -- stop RTL
+87 IF $DATA(XRT0)
SET XRTN=RPCNAME
IF $DATA(XRT0)
DO T1^%ZOSV
+88 ;
+89 ; -- empty write buffer of null device
+90 USE XOBNULL
SET DX=0
SET DY=0
XECUTE ^%ZOSF("XY")
+91 ;
+92 ; -- reset to use tcp port device to send results
+93 USE XOBPORT
+94 ;
+95 ; -- check for RPC processing timeout
+96 IF $$TOCHK^XOBVLIB()
Begin DoDot:1
+97 NEW PARAMS
SET PARAMS(1)=RPCNAME
SET PARAMS(2)=$$GETTO^XOBVLIB()
+98 DO ERROR(182007,RPCNAME,.PARAMS)
End DoDot:1
GOTO ENQ
+99 ;
+100 ; -- send results
+101 DO SEND(.XOBR)
+102 ;
ENQ ; -- end message handler
+1 DO CLEAN
+2 QUIT
+3 ;
CALLRPC(XWBPTYPE,XWBWRAP,XWBAPVER,METHSIG) ;-- execute RPC (use Broker RPC return type & wrap flag if there)
+1 DO @METHSIG
+2 QUIT
+3 ;
CLEAN ; -- clean up message handler environment
+1 NEW POS
+2 ; -- kill parameters
+3 SET POS=0
+4 FOR
SET POS=$ORDER(XOBDATA("XOB RPC","PARAMS",POS))
IF 'POS
QUIT
KILL @XOBDATA("XOB RPC","PARAMS",POS)
+5 QUIT
+6 ;
SEND(XOBR) ; -- stream rpc data to client
+1 NEW XOBFMT,XOBFILL
+2 ;
+3 SET XOBFMT=$$GETFMT()
+4 ; -- prepare socket for writing
+5 DO PRE^XOBVSKT
+6 ; -- initialize XML headers
+7 DO WRITE^XOBVSKT($$VLHDR^XOBVLIB(1))
+8 ; -- start response
+9 DO WRITE^XOBVSKT("<Response type="""_XOBFMT_""" ><![CDATA[")
+10 ; -- results
+11 DO PROCESS
+12 ; -- finalize
+13 DO WRITE^XOBVSKT("]]></Response>"_$$ENVFTR^XOBVLIB())
+14 ; -- send eot and flush buffer
+15 DO POST^XOBVSKT
+16 ;
+17 QUIT
+18 ;
DOCTYPE ;
+1 DO WRITE^XOBVSKT("<!DOCTYPE vistalink [<!ELEMENT vistalink (results) ><!ELEMENT results (#PCDATA)><!ATTLIST vistalink type CDATA ""Gov.VA.Med.RPC.Response"" ><!ATTLIST results type (array|string) >]>")
+2 QUIT
+3 ;
GETFMT() ; -- determine response format type
+1 IF XOBPTYPE=1!(XOBPTYPE=5)!(XOBPTYPE=6)
QUIT "string"
+2 IF XOBPTYPE=2
QUIT "array"
+3 ;
+4 QUIT $SELECT(XOBWRAP:"array",1:"string")
+5 ;
PROCESS ; -- send the real results
+1 NEW I,T,D
+2 ; -- single value
+3 IF XOBPTYPE=1
SET XOBR=$GET(XOBR)
DO WRITE^XOBVSKT(XOBR)
QUIT
+4 ; -- table delimited by CR+LF
+5 IF XOBPTYPE=2
Begin DoDot:1
+6 SET I=""
FOR
SET I=$ORDER(XOBR(I))
IF I=""
QUIT
DO WRITE^XOBVSKT(XOBR(I))
DO WRITE^XOBVSKT($CHAR(10))
End DoDot:1
QUIT
+7 ; -- word processing
+8 IF XOBPTYPE=3
Begin DoDot:1
+9 SET I=""
FOR
SET I=$ORDER(XOBR(I))
IF I=""
QUIT
DO WRITE^XOBVSKT(XOBR(I))
IF XOBWRAP
DO WRITE^XOBVSKT($CHAR(10))
End DoDot:1
QUIT
+10 ; -- global array
+11 IF XOBPTYPE=4
Begin DoDot:1
+12 IF $EXTRACT($GET(XOBR))'="^"
QUIT
+13 SET I=$GET(XOBR)
IF I=""
QUIT
SET T=$EXTRACT(I,1,$LENGTH(I)-1)
+14 ;Only send root node if non-null.
+15 IF $DATA(@I)>10
SET D=@I
IF $LENGTH(D)
DO WRITE^XOBVSKT(D)
IF XOBWRAP&(D'=$CHAR(10))
DO WRITE^XOBVSKT($CHAR(10))
+16 FOR
SET I=$QUERY(@I)
IF I=""!(I'[T)
QUIT
SET D=@I
DO WRITE^XOBVSKT(D)
IF XOBWRAP&(D'=$CHAR(10))
DO WRITE^XOBVSKT($CHAR(10))
+17 IF $DATA(@XOBR)
KILL @XOBR
End DoDot:1
QUIT
+18 ; -- global instance
+19 IF XOBPTYPE=5
Begin DoDot:1
+20 IF $EXTRACT($GET(XOBR))'="^"
QUIT
+21 SET XOBR=$GET(@XOBR)
DO WRITE^XOBVSKT(XOBR)
End DoDot:1
QUIT
+22 ; -- variable length records only good upto 255 char)
+23 IF XOBPTYPE=6
Begin DoDot:1
+24 SET I=""
FOR
SET I=$ORDER(XOBR(I))
IF I=""
QUIT
DO WRITE^XOBVSKT($CHAR($LENGTH(XOBR(I))))
DO WRITE^XOBVSKT(XOBR(I))
End DoDot:1
+25 QUIT
+26 ;
ERROR(CODE,RPCNAME,PARAMS) ; -- send rpc application error
+1 ; -- if parameters are passed as in CODE (where CODE = code^param1^param2^...)
+2 ; -- parse CODE and put parameters into PARAMS array.
+3 IF CODE[U
IF $DATA(PARAMS)=0
Begin DoDot:1
+4 KILL PARAMS
+5 FOR XOBI=2:1:$LENGTH(XOBERR,U)
SET PARAMS(XOBI-1)=$PIECE(XOBERR,U,XOBI)
+6 SET CODE=+CODE
End DoDot:1
+7 ;
+8 SET XOBDAT("MESSAGE TYPE")=2
+9 SET XOBDAT("ERRORS",1,"FAULT STRING")="Internal Application Error"
+10 SET XOBDAT("ERRORS",1,"FAULT ACTOR")=RPCNAME
+11 SET XOBDAT("ERRORS",1,"CODE")=CODE
+12 SET XOBDAT("ERRORS",1,"ERROR TYPE")=RPCNAME
+13 SET XOBDAT("ERRORS",1,"CDATA")=0
+14 SET XOBDAT("ERRORS",1,"MESSAGE",1)=$$EZBLD^DIALOG(CODE,.PARAMS)
+15 DO ERROR^XOBVLIB(.XOBDAT)
+16 ;
+17 ; -- save info in error system
+18 ;DO ^%ZTER
+19 QUIT
+20 ;
VER() ; -- check version and if re-authentication check is needed
+1 ; -- IMPORTANT: This tag needs updating for version numbers for each target release.
+2 ; -- This call needs only be called once per connection.
+3 ;
+4 NEW XOBERR,CV,SV,ENV
+5 ;
+6 KILL XOBSYS("RPC REAUTH")
+7 ;
+8 SET XOBERR=0
+9 ; -- default re-auh flag to true
+10 SET XOBRA=1
+11 ; -- client version
+12 SET CV=XOBDATA("XOB RPC","RPC HANDLER VERSION")
+13 ; -- current server version
+14 SET SV="1.5"
+15 ; -- client environment
+16 SET ENV=XOBSYS("ENV")
+17 ;
+18 ; -- if client version is not supported then return error
+19 IF ("^1.0^1.5^")'[(U_CV_U)
Begin DoDot:1
+20 SET XOBERR=182009_U_CV_U_SV_U_"Client version not supported"
End DoDot:1
GOTO VERQ
+21 ;
+22 ; -- if client environment is not supported then return error
+23 IF ("^j2se^j2ee^.net^")'[(U_ENV_U)
Begin DoDot:1
+24 SET XOBERR=182009_U_CV_U_SV_U_"Client environment ("_$$UP^XLFSTR(ENV)_") not supported"
End DoDot:1
GOTO VERQ
+25 ;
+26 ; -- if client/server environment then ok
+27 IF ("^j2se^.net^")[(U_ENV_U)
SET XOBRA=0
GOTO VERQ
+28 ;
+29 ; -- if client version is "1.0" and client is j2ee then return error
+30 IF CV="1.0"
IF ENV="j2ee"
Begin DoDot:1
+31 SET XOBERR=182009_U_CV_U_SV_U_"Client RPC version does not support "_$$UP^XLFSTR(ENV)
End DoDot:1
GOTO VERQ
+32 ;
+33 ; -- if client version supports j2ee and client is j2ee then ok (default)
+34 ;IF ENV="j2ee" GOTO VERQ
+35 ;
VERQ ;
+1 IF 'XOBERR
SET XOBSYS("RPC REAUTH")=XOBRA
+2 QUIT XOBERR
+3 ;
