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