XOBVRPC ;; mjk/alb - VistaLink RPC Server Listener Code ; 07/27/2002 13:00
;;1.6;VistALink Security;**4**;May 08, 2009;Build 7
; ;Per VA Directive 6402, this routine should not be modified.
Q
;
; ------------------------------------------------------------------------
; RPC Server: Message Request Handler
; ------------------------------------------------------------------------
;
EN(XOBDATA) ; -- handle parsed messages request
N DX,DY,RPC0,RPCNAME,RPCIEN,TAG,ROU,METHSIG,XOBERR,XOBR,XOBSEC,XOBWRAP,XOBPTYPE,XRTN,XOBRA,XOBVER
;
I $G(XOBDATA("XOB RPC","RPC NAME"))="" D G ENQ
. D ERROR(182001,"[No RPC]","")
;
S RPCNAME=XOBDATA("XOB RPC","RPC NAME")
;
I $D(^XWB(8994,"B",RPCNAME))=0 D G ENQ
. D ERROR(182002,RPCNAME,RPCNAME)
;
I $D(^XWB(8994,"B",RPCNAME))=10 S RPCIEN=+$O(^XWB(8994,"B",RPCNAME,""))
;
; -- get zero node
S RPC0=$G(^XWB(8994,RPCIEN,0))
;
; -- make sure there is data on node
I RPC0="" D G ENQ
. D ERROR(182003,RPCNAME,RPCNAME)
;
; -- make sure x-ref is not corrupt and found the wrong entry
I RPCNAME'=$P(RPC0,U) D G ENQ
. N PARAMS S PARAMS(1)=RPCNAME,PARAMS(2)=$P(RPC0,U)
. D ERROR(182008,RPCNAME,.PARAMS)
;
; -- check inactive flag
I $P(RPC0,U,6)=1!($P(RPC0,U,6)=2) D G ENQ
. D ERROR(182004,RPCNAME,RPCNAME)
;
; -- if not already performed, check version, environment and set re-auth check flag
S XOBERR=$S($D(XOBSYS("RPC REAUTH")):0,1:$$VER())
I XOBERR D G ENQ
. D ERROR(XOBERR,RPCNAME)
;
; -- reauthentication checks
S XOBERR=0
I +$G(XOBSYS("RPC REAUTH")) D G:XOBERR ENQ
. ;
. ; -- reauthenticate user based on type (i.e. DUZ,AV,VPID,CCOW,APPPROXY)
. S XOBERR=$$SETUPDUZ^XOBSRA()
. I XOBERR D ERROR(XOBERR,RPCNAME) Q
. ;
. ; -- if application proxy user, check if allowed to run RPC
. I $$UP^XLFSTR(XOBDATA("XOB RPC","SECURITY","TYPE"))="APPPROXY",'$$RPC^XUSAP($G(RPCIEN)) D Q
.. S XOBERR=182010
.. D ERROR(XOBERR,RPCNAME,RPCNAME)
;
; -- set context
S XOBSEC=$$CRCONTXT^XOBSCAV($G(XOBDATA("XOB RPC","RPC CONTEXT")))
I '+XOBSEC D G ENQ
. D ERROR(182005,RPCNAME,XOBSEC)
;
; -- check if appropriate context created
S XOBSEC=$$CHKCTXT^XOBSCAV(RPCNAME)
I '+XOBSEC D G ENQ
. D ERROR(182006,RPCNAME,XOBSEC)
;
; -- setup timeout info
S XOBDATA("XOB RPC","TIMED OUT")=0
S XOBDATA("XOB RPC","START")=$H
;
; -- setup info needed for RPC execution
S TAG=$P(RPC0,U,2)
S ROU=$P(RPC0,U,3)
S XOBPTYPE=$P(RPC0,U,4)
S XOBWRAP=$P(RPC0,U,8)
S XOBVER=$$GETVER^XOBVRPCX()
;
; -- build method signature
S METHSIG=TAG_"^"_ROU_"(.XOBR"_$G(XOBDATA("XOB RPC","PARAMS"))_")"
;
; -- start RTL
D:$D(XRTL) T0^%ZOSV
;
; -- use null device in case of writing during RPC execution
U XOBNULL
;
; -- start RUM for RPC Name
D LOGRSRC^%ZOSV(RPCNAME,2,1)
;
; -- execute RPC
D CALLRPC(.XOBPTYPE,.XOBWRAP,.XOBVER,METHSIG)
;
; -- re-start RUM for VistaLink Handler
D LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1)
;
; -- stop RTL
S:$D(XRT0) XRTN=RPCNAME D:$D(XRT0) T1^%ZOSV
;
; -- empty write buffer of null device
U XOBNULL S DX=0,DY=0 X ^%ZOSF("XY")
;
; -- reset to use tcp port device to send results
U XOBPORT
;
; -- check for RPC processing timeout
I $$TOCHK^XOBVLIB() D G ENQ
. N PARAMS S PARAMS(1)=RPCNAME,PARAMS(2)=$$GETTO^XOBVLIB()
. D ERROR(182007,RPCNAME,.PARAMS)
;
; -- send results
D SEND(.XOBR)
;
ENQ ; -- end message handler
D CLEAN
Q
;
CALLRPC(XWBPTYPE,XWBWRAP,XWBAPVER,METHSIG) ;-- execute RPC (use Broker RPC return type & wrap flag if there)
D @METHSIG
Q
;
CLEAN ; -- clean up message handler environment
N POS
; -- kill parameters
S POS=0
F S POS=$O(XOBDATA("XOB RPC","PARAMS",POS)) Q:'POS K @XOBDATA("XOB RPC","PARAMS",POS)
Q
;
SEND(XOBR) ; -- stream rpc data to client
N XOBFMT,XOBFILL
;
S XOBFMT=$$GETFMT()
; -- prepare socket for writing
D PRE^XOBVSKT
; -- initialize XML headers
D WRITE^XOBVSKT($$VLHDR^XOBVLIB(1))
; -- start response
D WRITE^XOBVSKT("<Response type="""_XOBFMT_""" ><![CDATA[")
; -- results
D PROCESS
; -- finalize
D WRITE^XOBVSKT("]]></Response>"_$$ENVFTR^XOBVLIB())
; -- send eot and flush buffer
D POST^XOBVSKT
;
Q
;
DOCTYPE ;
D WRITE^XOBVSKT("<!DOCTYPE vistalink [<!ELEMENT vistalink (results) ><!ELEMENT results (#PCDATA)><!ATTLIST vistalink type CDATA ""Gov.VA.Med.RPC.Response"" ><!ATTLIST results type (array|string) >]>")
Q
;
GETFMT() ; -- determine response format type
I XOBPTYPE=1!(XOBPTYPE=5)!(XOBPTYPE=6) Q "string"
I XOBPTYPE=2 Q "array"
;
Q $S(XOBWRAP:"array",1:"string")
;
PROCESS ; -- send the real results
N I,T,D
; -- single value
I XOBPTYPE=1 S XOBR=$G(XOBR) D WRITE^XOBVSKT(XOBR) Q
; -- table delimited by CR+LF
I XOBPTYPE=2 D Q
. S I="" F S I=$O(XOBR(I)) Q:I="" D WRITE^XOBVSKT(XOBR(I)),WRITE^XOBVSKT($C(10))
; -- word processing
I XOBPTYPE=3 D Q
. S I="" F S I=$O(XOBR(I)) Q:I="" D WRITE^XOBVSKT(XOBR(I)) D:XOBWRAP WRITE^XOBVSKT($C(10))
; -- global array
I XOBPTYPE=4 D Q
. I $E($G(XOBR))'="^" Q
. S I=$G(XOBR) Q:I="" S T=$E(I,1,$L(I)-1)
. ;Only send root node if non-null.
. I $D(@I)>10 S D=@I I $L(D) D WRITE^XOBVSKT(D),WRITE^XOBVSKT($C(10)):XOBWRAP&(D'=$C(10))
. F S I=$Q(@I) Q:I=""!(I'[T) S D=@I D WRITE^XOBVSKT(D),WRITE^XOBVSKT($C(10)):XOBWRAP&(D'=$C(10))
. I $D(@XOBR) K @XOBR
; -- global instance
I XOBPTYPE=5 D Q
. I $E($G(XOBR))'="^" Q
. S XOBR=$G(@XOBR) D WRITE^XOBVSKT(XOBR)
; -- variable length records only good up to 255 char)
I XOBPTYPE=6 D
. S I="" F S I=$O(XOBR(I)) Q:I="" D WRITE^XOBVSKT($C($L(XOBR(I)))),WRITE^XOBVSKT(XOBR(I))
Q
;
ERROR(CODE,RPCNAME,PARAMS) ; -- send rpc application error
N XOBI,XOBDAT,$ET,$ES
; -- if parameters are passed as in CODE (where CODE = code^param1^param2^...)
; -- parse CODE and put parameters into PARAMS array.
I CODE[U,$D(PARAMS)=0 D
. K PARAMS
. F XOBI=2:1:$L(XOBERR,U) S PARAMS(XOBI-1)=$P(XOBERR,U,XOBI)
. S CODE=+CODE
;
S XOBDAT("MESSAGE TYPE")=2
S XOBDAT("ERRORS",1,"FAULT STRING")="Internal Application Error"
S XOBDAT("ERRORS",1,"FAULT ACTOR")=RPCNAME
S XOBDAT("ERRORS",1,"CODE")=CODE
S XOBDAT("ERRORS",1,"ERROR TYPE")=RPCNAME
S XOBDAT("ERRORS",1,"CDATA")=0
S XOBDAT("ERRORS",1,"MESSAGE",1)=$$EZBLD^DIALOG(CODE,.PARAMS)
D ERROR^XOBVLIB(.XOBDAT)
;
; -- save info in error system
D APPERROR^%ZTER("VistALink Error "_CODE) ;*4
Q
;
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.
;
N XOBERR,CV,SV,ENV
;
K XOBSYS("RPC REAUTH")
;
S XOBERR=0
; -- default re-auh flag to true
S XOBRA=1
; -- client version
S CV=XOBDATA("XOB RPC","RPC HANDLER VERSION")
; -- current server version
S SV="1.6"
; -- client environment
S ENV=XOBSYS("ENV")
;
; -- if client version is not supported then return error
I ("^1.0^1.5^1.6^")'[(U_CV_U) D G VERQ
. S XOBERR=182009_U_CV_U_SV_U_"Client version not supported"
;
; -- if client environment is not supported then return error
I ("^j2se^j2ee^.net^")'[(U_ENV_U) D G VERQ
. S XOBERR=182009_U_CV_U_SV_U_"Client environment ("_$$UP^XLFSTR(ENV)_") not supported"
;
; -- if client/server environment then ok
I ("^j2se^.net^")[(U_ENV_U) S XOBRA=0 G VERQ
;
; -- if client version is "1.0" and client is j2ee then return error
I CV="1.0",ENV="j2ee" D G VERQ
. S 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 ;
I 'XOBERR S XOBSYS("RPC REAUTH")=XOBRA
Q XOBERR
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBVRPC 7816 printed Dec 13, 2024@02:44:51 Page 2
XOBVRPC ;; mjk/alb - VistaLink RPC Server Listener Code ; 07/27/2002 13:00
+1 ;;1.6;VistALink Security;**4**;May 08, 2009;Build 7
+2 ; ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; ------------------------------------------------------------------------
+6 ; RPC Server: Message Request Handler
+7 ; ------------------------------------------------------------------------
+8 ;
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 up to 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 NEW XOBI,XOBDAT,$ETRAP,$ESTACK
+2 ; -- if parameters are passed as in CODE (where CODE = code^param1^param2^...)
+3 ; -- parse CODE and put parameters into PARAMS array.
+4 IF CODE[U
IF $DATA(PARAMS)=0
Begin DoDot:1
+5 KILL PARAMS
+6 FOR XOBI=2:1:$LENGTH(XOBERR,U)
SET PARAMS(XOBI-1)=$PIECE(XOBERR,U,XOBI)
+7 SET CODE=+CODE
End DoDot:1
+8 ;
+9 SET XOBDAT("MESSAGE TYPE")=2
+10 SET XOBDAT("ERRORS",1,"FAULT STRING")="Internal Application Error"
+11 SET XOBDAT("ERRORS",1,"FAULT ACTOR")=RPCNAME
+12 SET XOBDAT("ERRORS",1,"CODE")=CODE
+13 SET XOBDAT("ERRORS",1,"ERROR TYPE")=RPCNAME
+14 SET XOBDAT("ERRORS",1,"CDATA")=0
+15 SET XOBDAT("ERRORS",1,"MESSAGE",1)=$$EZBLD^DIALOG(CODE,.PARAMS)
+16 DO ERROR^XOBVLIB(.XOBDAT)
+17 ;
+18 ; -- save info in error system
+19 ;*4
DO APPERROR^%ZTER("VistALink Error "_CODE)
+20 QUIT
+21 ;
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.6"
+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^1.6^")'[(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 ;
