XOBVRPCX ;; mjk/alb - VistaLink RPC Formatter Sink ; 07/27/2002 13:00
;;1.6;VistALink;;May 08, 2009;Build 15
;Per VHA directive 2004-038, this routine should not be modified.
QUIT
;
; -- unwrap stream
START(XOBUF,XOBDATA) ;
NEW PARAMS,POS,TYP,PCNT,CNTP,ICNT,CNTI,XOBPN,SUB,VAL,DEBUG,EOT,RESV,LENSIZE,X
;
; -- get debugging byte
SET DEBUG=$$GETSTR(1)
;
; -- get size of length chunk
SET LENSIZE=$$GETSTR(1)
;
; -- get VistaLink version
SET XOBDATA("VL VERSION")=$$GETVAL()
;
; -- get RpcHandler version
SET XOBDATA("XOB RPC","RPC HANDLER VERSION")=$$GETVAL()
;
; -- Set basic constant attributes
SET XOBDATA("MODE")="singleton"
;
; -- get RPC info from stream
IF XOBDATA("XOB RPC","RPC HANDLER VERSION")>1.0 SET X=$$SETVER($$GETVAL())
SET XOBDATA("XOB RPC","RPC NAME")=$$GETVAL()
SET XOBDATA("XOB RPC","RPC CONTEXT")=$$GETVAL()
;
; -- set RPC time out
SET X=$$SETTO^XOBVLIB($$GETVAL())
;
; -- set security info
DO SECURITY
;
; -- set RPC parameters
DO PARMS
;
; -- read end of text character EOT to empty buffer
SET EOT=$$GETSTR(1)
QUIT
;
GETVAL() ; -- get next VALue from stream buffer
QUIT $$GETSTR($$GETLEN())
;
GETLEN() ; -- get the length of the next value
IF 'DEBUG QUIT +$$GETSTR(LENSIZE)
; -- Ex. of why 4: VAL=00001
QUIT +$PIECE($$GETSTR(LENSIZE+4),"=",2)
;
GETSTR(LEN) ; -- extracts string of length, LEN, from stream buffer and returns extracted string
NEW X
FOR QUIT:($LENGTH(XOBUF)'<LEN) DO READ(LEN-$LENGTH(XOBUF))
SET X=$EXTRACT(XOBUF,1,LEN)
SET XOBUF=$EXTRACT(XOBUF,LEN+1,999)
QUIT X
;
READ(LEN) ; -- read more from stream buffer but only needed amount
NEW X
FOR QUIT:LEN<512 SET LEN=LEN-511 READ X#511:1 SET XOBUF=XOBUF_X
IF LEN>0 READ X#LEN:1 SET XOBUF=XOBUF_X
QUIT
;
;
; ---------------- Security Information Processing ----------------
SECURITY ;
;
; -- if called from VL v1.0 client then set up J2SE defaults
IF $GET(XOBDATA("VL VERSION"))="1.0" DO V1 QUIT
;
; -- set security info
SET XOBDATA("XOB RPC","SECURITY","TYPE")=$$GETVAL()
SET XOBDATA("XOB RPC","SECURITY","DIV")=$$GETVAL()
SET XOBDATA("XOB RPC","SECURITY","STATE")=$$GETVAL()
;
; -- get needed type vars if not authenticated
IF XOBDATA("XOB RPC","SECURITY","STATE")'="authenticated" DO
. DO @($$UP^XLFSTR($GET(XOBDATA("XOB RPC","SECURITY","TYPE"))))
;
QUIT
;
AV ; -- access and verify code type (KAAJEE)
SET XOBDATA("XOB RPC","SECURITY","TYPE","AVCODE")=$$GETVAL()
QUIT
;
CCOW ; -- CCOW type (FatKAAT)
SET XOBDATA("XOB RPC","SECURITY","TYPE","CCOW")=$$GETVAL()
QUIT
;
DUZ ; -- simple duz type
SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
QUIT
;
VPID ; -- vpid type
SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
QUIT
;
APPPROXY ; -- application proxy type
SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
QUIT
;
J2SE ; -- c/s type
; -- this line should never be executed since state will
; always be authenticated ; entered for completeness
QUIT
;
V1 ; -- set up security compatibility for VL v1.0 client
; (tag also called by ELST^XOBRPCI)
;
SET XOBDATA("XOB RPC","SECURITY","TYPE")="j2se"
SET XOBDATA("XOB RPC","SECURITY","DIV")=""
SET XOBDATA("XOB RPC","SECURITY","STATE")="authenticated"
QUIT
; --------------------- RPC Parameter Processing -----------------
PARMS ;
;
; -- get how many parameters to expect
SET XOBDATA("XOB RPC","PARAMS")=""
SET PCNT=+$$GETVAL()
;
; -- get the parameters
IF PCNT>0 FOR CNTP=1:1:PCNT DO
. SET TYP=$$GETVAL()
. SET POS=+$$GETVAL()
. SET XOBPN="XOBP"_POS
. SET XOBDATA("XOB RPC","PARAMS",POS)=XOBPN
. ;
. ; -- get single value
. IF TYP'="array" DO QUIT
. . ; -- get value for ref type
. . IF TYP="ref" SET @XOBPN=@$$GETVAL() QUIT
. . ;
. . ; -- get value for other non-array types
. . SET @XOBPN=$$GETVAL()
. ;
. ; -- get how many subscripts to expect for an array
. SET ICNT=+$$GETVAL()
. ;
. ; -- set root node of array to ""
. SET @XOBPN=""
. ;
. ; -- get the subscripts and values for the array
. IF ICNT>0 FOR CNTI=1:1:ICNT DO
. . SET SUB=$$GETVAL()
. . SET VAL=$$GETVAL()
. . IF $EXTRACT(SUB,1)=$CHAR(13) DO
. . . SET @("@XOBPN@("_$EXTRACT(SUB,2,$LENGTH(SUB))_")=VAL")
. . ELSE DO
. . . SET @XOBPN@(SUB)=VAL
;
; -- build parameter signature for RPC call
SET PARAMS="",POS=0
FOR SET POS=$ORDER(XOBDATA("XOB RPC","PARAMS",POS)) QUIT:'POS SET PARAMS=PARAMS_",."_XOBDATA("XOB RPC","PARAMS",POS)
SET XOBDATA("XOB RPC","PARAMS")=PARAMS
;
QUIT
;
; ------------------------------------------------------------------
;
GETVER() ; -- get rpc version
QUIT $GET(XOBDATA("XOB RPC","VERSION"),0)
;
SETVER(VERSION) ; -- set rpc version
SET XOBDATA("XOB RPC","VERSION")=VERSION
QUIT 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBVRPCX 4878 printed Apr 09, 2024@21:47:03 Page 2
XOBVRPCX ;; mjk/alb - VistaLink RPC Formatter Sink ; 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.
+3 QUIT
+4 ;
+5 ; -- unwrap stream
START(XOBUF,XOBDATA) ;
+1 NEW PARAMS,POS,TYP,PCNT,CNTP,ICNT,CNTI,XOBPN,SUB,VAL,DEBUG,EOT,RESV,LENSIZE,X
+2 ;
+3 ; -- get debugging byte
+4 SET DEBUG=$$GETSTR(1)
+5 ;
+6 ; -- get size of length chunk
+7 SET LENSIZE=$$GETSTR(1)
+8 ;
+9 ; -- get VistaLink version
+10 SET XOBDATA("VL VERSION")=$$GETVAL()
+11 ;
+12 ; -- get RpcHandler version
+13 SET XOBDATA("XOB RPC","RPC HANDLER VERSION")=$$GETVAL()
+14 ;
+15 ; -- Set basic constant attributes
+16 SET XOBDATA("MODE")="singleton"
+17 ;
+18 ; -- get RPC info from stream
+19 IF XOBDATA("XOB RPC","RPC HANDLER VERSION")>1.0
SET X=$$SETVER($$GETVAL())
+20 SET XOBDATA("XOB RPC","RPC NAME")=$$GETVAL()
+21 SET XOBDATA("XOB RPC","RPC CONTEXT")=$$GETVAL()
+22 ;
+23 ; -- set RPC time out
+24 SET X=$$SETTO^XOBVLIB($$GETVAL())
+25 ;
+26 ; -- set security info
+27 DO SECURITY
+28 ;
+29 ; -- set RPC parameters
+30 DO PARMS
+31 ;
+32 ; -- read end of text character EOT to empty buffer
+33 SET EOT=$$GETSTR(1)
+34 QUIT
+35 ;
GETVAL() ; -- get next VALue from stream buffer
+1 QUIT $$GETSTR($$GETLEN())
+2 ;
GETLEN() ; -- get the length of the next value
+1 IF 'DEBUG
QUIT +$$GETSTR(LENSIZE)
+2 ; -- Ex. of why 4: VAL=00001
+3 QUIT +$PIECE($$GETSTR(LENSIZE+4),"=",2)
+4 ;
GETSTR(LEN) ; -- extracts string of length, LEN, from stream buffer and returns extracted string
+1 NEW X
+2 FOR
if ($LENGTH(XOBUF)'<LEN)
QUIT
DO READ(LEN-$LENGTH(XOBUF))
+3 SET X=$EXTRACT(XOBUF,1,LEN)
+4 SET XOBUF=$EXTRACT(XOBUF,LEN+1,999)
+5 QUIT X
+6 ;
READ(LEN) ; -- read more from stream buffer but only needed amount
+1 NEW X
+2 FOR
if LEN<512
QUIT
SET LEN=LEN-511
READ X#511:1
SET XOBUF=XOBUF_X
+3 IF LEN>0
READ X#LEN:1
SET XOBUF=XOBUF_X
+4 QUIT
+5 ;
+6 ;
+7 ; ---------------- Security Information Processing ----------------
SECURITY ;
+1 ;
+2 ; -- if called from VL v1.0 client then set up J2SE defaults
+3 IF $GET(XOBDATA("VL VERSION"))="1.0"
DO V1
QUIT
+4 ;
+5 ; -- set security info
+6 SET XOBDATA("XOB RPC","SECURITY","TYPE")=$$GETVAL()
+7 SET XOBDATA("XOB RPC","SECURITY","DIV")=$$GETVAL()
+8 SET XOBDATA("XOB RPC","SECURITY","STATE")=$$GETVAL()
+9 ;
+10 ; -- get needed type vars if not authenticated
+11 IF XOBDATA("XOB RPC","SECURITY","STATE")'="authenticated"
Begin DoDot:1
+12 DO @($$UP^XLFSTR($GET(XOBDATA("XOB RPC","SECURITY","TYPE"))))
End DoDot:1
+13 ;
+14 QUIT
+15 ;
AV ; -- access and verify code type (KAAJEE)
+1 SET XOBDATA("XOB RPC","SECURITY","TYPE","AVCODE")=$$GETVAL()
+2 QUIT
+3 ;
CCOW ; -- CCOW type (FatKAAT)
+1 SET XOBDATA("XOB RPC","SECURITY","TYPE","CCOW")=$$GETVAL()
+2 QUIT
+3 ;
DUZ ; -- simple duz type
+1 SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
+2 QUIT
+3 ;
VPID ; -- vpid type
+1 SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
+2 QUIT
+3 ;
APPPROXY ; -- application proxy type
+1 SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
+2 QUIT
+3 ;
J2SE ; -- c/s type
+1 ; -- this line should never be executed since state will
+2 ; always be authenticated ; entered for completeness
+3 QUIT
+4 ;
V1 ; -- set up security compatibility for VL v1.0 client
+1 ; (tag also called by ELST^XOBRPCI)
+2 ;
+3 SET XOBDATA("XOB RPC","SECURITY","TYPE")="j2se"
+4 SET XOBDATA("XOB RPC","SECURITY","DIV")=""
+5 SET XOBDATA("XOB RPC","SECURITY","STATE")="authenticated"
+6 QUIT
+7 ; --------------------- RPC Parameter Processing -----------------
PARMS ;
+1 ;
+2 ; -- get how many parameters to expect
+3 SET XOBDATA("XOB RPC","PARAMS")=""
+4 SET PCNT=+$$GETVAL()
+5 ;
+6 ; -- get the parameters
+7 IF PCNT>0
FOR CNTP=1:1:PCNT
Begin DoDot:1
+8 SET TYP=$$GETVAL()
+9 SET POS=+$$GETVAL()
+10 SET XOBPN="XOBP"_POS
+11 SET XOBDATA("XOB RPC","PARAMS",POS)=XOBPN
+12 ;
+13 ; -- get single value
+14 IF TYP'="array"
Begin DoDot:2
+15 ; -- get value for ref type
+16 IF TYP="ref"
SET @XOBPN=@$$GETVAL()
QUIT
+17 ;
+18 ; -- get value for other non-array types
+19 SET @XOBPN=$$GETVAL()
End DoDot:2
QUIT
+20 ;
+21 ; -- get how many subscripts to expect for an array
+22 SET ICNT=+$$GETVAL()
+23 ;
+24 ; -- set root node of array to ""
+25 SET @XOBPN=""
+26 ;
+27 ; -- get the subscripts and values for the array
+28 IF ICNT>0
FOR CNTI=1:1:ICNT
Begin DoDot:2
+29 SET SUB=$$GETVAL()
+30 SET VAL=$$GETVAL()
+31 IF $EXTRACT(SUB,1)=$CHAR(13)
Begin DoDot:3
+32 SET @("@XOBPN@("_$EXTRACT(SUB,2,$LENGTH(SUB))_")=VAL")
End DoDot:3
+33 IF '$TEST
Begin DoDot:3
+34 SET @XOBPN@(SUB)=VAL
End DoDot:3
End DoDot:2
End DoDot:1
+35 ;
+36 ; -- build parameter signature for RPC call
+37 SET PARAMS=""
SET POS=0
+38 FOR
SET POS=$ORDER(XOBDATA("XOB RPC","PARAMS",POS))
if 'POS
QUIT
SET PARAMS=PARAMS_",."_XOBDATA("XOB RPC","PARAMS",POS)
+39 SET XOBDATA("XOB RPC","PARAMS")=PARAMS
+40 ;
+41 QUIT
+42 ;
+43 ; ------------------------------------------------------------------
+44 ;
GETVER() ; -- get rpc version
+1 QUIT $GET(XOBDATA("XOB RPC","VERSION"),0)
+2 ;
SETVER(VERSION) ; -- set rpc version
+1 SET XOBDATA("XOB RPC","VERSION")=VERSION
+2 QUIT 1
+3 ;
