source: FOIAVistA/tag/r/VISTALINK-XOBV/XOBVRPCX.m@ 1700

XOBVRPCX ;; mjk/alb - VistaLink RPC Formatter Sink ; 07/27/2002  13:00
 ;;1.5;VistALink;;Sep 09, 2005
 ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
 ;
 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 Paramter 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
 ;