Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XOBVRPCX

XOBVRPCX.m

Go to the documentation of this file.
  1. XOBVRPCX ;; mjk/alb - VistaLink RPC Formatter Sink ; 07/27/2002 13:00
  1. ;;1.6;VistALink;;May 08, 2009;Build 15
  1. ;Per VHA directive 2004-038, this routine should not be modified.
  1. QUIT
  1. ;
  1. ; -- unwrap stream
  1. START(XOBUF,XOBDATA) ;
  1. NEW PARAMS,POS,TYP,PCNT,CNTP,ICNT,CNTI,XOBPN,SUB,VAL,DEBUG,EOT,RESV,LENSIZE,X
  1. ;
  1. ; -- get debugging byte
  1. SET DEBUG=$$GETSTR(1)
  1. ;
  1. ; -- get size of length chunk
  1. SET LENSIZE=$$GETSTR(1)
  1. ;
  1. ; -- get VistaLink version
  1. SET XOBDATA("VL VERSION")=$$GETVAL()
  1. ;
  1. ; -- get RpcHandler version
  1. SET XOBDATA("XOB RPC","RPC HANDLER VERSION")=$$GETVAL()
  1. ;
  1. ; -- Set basic constant attributes
  1. SET XOBDATA("MODE")="singleton"
  1. ;
  1. ; -- get RPC info from stream
  1. IF XOBDATA("XOB RPC","RPC HANDLER VERSION")>1.0 SET X=$$SETVER($$GETVAL())
  1. SET XOBDATA("XOB RPC","RPC NAME")=$$GETVAL()
  1. SET XOBDATA("XOB RPC","RPC CONTEXT")=$$GETVAL()
  1. ;
  1. ; -- set RPC time out
  1. SET X=$$SETTO^XOBVLIB($$GETVAL())
  1. ;
  1. ; -- set security info
  1. DO SECURITY
  1. ;
  1. ; -- set RPC parameters
  1. DO PARMS
  1. ;
  1. ; -- read end of text character EOT to empty buffer
  1. SET EOT=$$GETSTR(1)
  1. QUIT
  1. ;
  1. GETVAL() ; -- get next VALue from stream buffer
  1. QUIT $$GETSTR($$GETLEN())
  1. ;
  1. GETLEN() ; -- get the length of the next value
  1. IF 'DEBUG QUIT +$$GETSTR(LENSIZE)
  1. ; -- Ex. of why 4: VAL=00001
  1. QUIT +$PIECE($$GETSTR(LENSIZE+4),"=",2)
  1. ;
  1. GETSTR(LEN) ; -- extracts string of length, LEN, from stream buffer and returns extracted string
  1. NEW X
  1. FOR QUIT:($LENGTH(XOBUF)'<LEN) DO READ(LEN-$LENGTH(XOBUF))
  1. SET X=$EXTRACT(XOBUF,1,LEN)
  1. SET XOBUF=$EXTRACT(XOBUF,LEN+1,999)
  1. QUIT X
  1. ;
  1. READ(LEN) ; -- read more from stream buffer but only needed amount
  1. NEW X
  1. FOR QUIT:LEN<512 SET LEN=LEN-511 READ X#511:1 SET XOBUF=XOBUF_X
  1. IF LEN>0 READ X#LEN:1 SET XOBUF=XOBUF_X
  1. QUIT
  1. ;
  1. ;
  1. ; ---------------- Security Information Processing ----------------
  1. SECURITY ;
  1. ;
  1. ; -- if called from VL v1.0 client then set up J2SE defaults
  1. IF $GET(XOBDATA("VL VERSION"))="1.0" DO V1 QUIT
  1. ;
  1. ; -- set security info
  1. SET XOBDATA("XOB RPC","SECURITY","TYPE")=$$GETVAL()
  1. SET XOBDATA("XOB RPC","SECURITY","DIV")=$$GETVAL()
  1. SET XOBDATA("XOB RPC","SECURITY","STATE")=$$GETVAL()
  1. ;
  1. ; -- get needed type vars if not authenticated
  1. IF XOBDATA("XOB RPC","SECURITY","STATE")'="authenticated" DO
  1. . DO @($$UP^XLFSTR($GET(XOBDATA("XOB RPC","SECURITY","TYPE"))))
  1. ;
  1. QUIT
  1. ;
  1. AV ; -- access and verify code type (KAAJEE)
  1. SET XOBDATA("XOB RPC","SECURITY","TYPE","AVCODE")=$$GETVAL()
  1. QUIT
  1. ;
  1. CCOW ; -- CCOW type (FatKAAT)
  1. SET XOBDATA("XOB RPC","SECURITY","TYPE","CCOW")=$$GETVAL()
  1. QUIT
  1. ;
  1. DUZ ; -- simple duz type
  1. SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
  1. QUIT
  1. ;
  1. VPID ; -- vpid type
  1. SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
  1. QUIT
  1. ;
  1. APPPROXY ; -- application proxy type
  1. SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
  1. QUIT
  1. ;
  1. J2SE ; -- c/s type
  1. ; -- this line should never be executed since state will
  1. ; always be authenticated ; entered for completeness
  1. QUIT
  1. ;
  1. V1 ; -- set up security compatibility for VL v1.0 client
  1. ; (tag also called by ELST^XOBRPCI)
  1. ;
  1. SET XOBDATA("XOB RPC","SECURITY","TYPE")="j2se"
  1. SET XOBDATA("XOB RPC","SECURITY","DIV")=""
  1. SET XOBDATA("XOB RPC","SECURITY","STATE")="authenticated"
  1. QUIT
  1. ; --------------------- RPC Parameter Processing -----------------
  1. PARMS ;
  1. ;
  1. ; -- get how many parameters to expect
  1. SET XOBDATA("XOB RPC","PARAMS")=""
  1. SET PCNT=+$$GETVAL()
  1. ;
  1. ; -- get the parameters
  1. IF PCNT>0 FOR CNTP=1:1:PCNT DO
  1. . SET TYP=$$GETVAL()
  1. . SET POS=+$$GETVAL()
  1. . SET XOBPN="XOBP"_POS
  1. . SET XOBDATA("XOB RPC","PARAMS",POS)=XOBPN
  1. . ;
  1. . ; -- get single value
  1. . IF TYP'="array" DO QUIT
  1. . . ; -- get value for ref type
  1. . . IF TYP="ref" SET @XOBPN=@$$GETVAL() QUIT
  1. . . ;
  1. . . ; -- get value for other non-array types
  1. . . SET @XOBPN=$$GETVAL()
  1. . ;
  1. . ; -- get how many subscripts to expect for an array
  1. . SET ICNT=+$$GETVAL()
  1. . ;
  1. . ; -- set root node of array to ""
  1. . SET @XOBPN=""
  1. . ;
  1. . ; -- get the subscripts and values for the array
  1. . IF ICNT>0 FOR CNTI=1:1:ICNT DO
  1. . . SET SUB=$$GETVAL()
  1. . . SET VAL=$$GETVAL()
  1. . . IF $EXTRACT(SUB,1)=$CHAR(13) DO
  1. . . . SET @("@XOBPN@("_$EXTRACT(SUB,2,$LENGTH(SUB))_")=VAL")
  1. . . ELSE DO
  1. . . . SET @XOBPN@(SUB)=VAL
  1. ;
  1. ; -- build parameter signature for RPC call
  1. SET PARAMS="",POS=0
  1. FOR SET POS=$ORDER(XOBDATA("XOB RPC","PARAMS",POS)) QUIT:'POS SET PARAMS=PARAMS_",."_XOBDATA("XOB RPC","PARAMS",POS)
  1. SET XOBDATA("XOB RPC","PARAMS")=PARAMS
  1. ;
  1. QUIT
  1. ;
  1. ; ------------------------------------------------------------------
  1. ;
  1. GETVER() ; -- get rpc version
  1. QUIT $GET(XOBDATA("XOB RPC","VERSION"),0)
  1. ;
  1. SETVER(VERSION) ; -- set rpc version
  1. SET XOBDATA("XOB RPC","VERSION")=VERSION
  1. QUIT 1
  1. ;