- 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 Feb 19, 2025@00:11:22 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 ;