source: FOIAVistA/trunk/r/VISTALINK-XOBV/XOBVRPCX.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1XOBVRPCX ;; mjk/alb - VistaLink RPC Formatter Sink ; 07/27/2002 13:00
2 ;;1.5;VistALink;;Sep 09, 2005
3 ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
4 ;
5 QUIT
6 ;
7 ; -- unwrap stream
8START(XOBUF,XOBDATA) ;
9 NEW PARAMS,POS,TYP,PCNT,CNTP,ICNT,CNTI,XOBPN,SUB,VAL,DEBUG,EOT,RESV,LENSIZE,X
10 ;
11 ; -- get debugging byte
12 SET DEBUG=$$GETSTR(1)
13 ;
14 ; -- get size of length chunk
15 SET LENSIZE=$$GETSTR(1)
16 ;
17 ; -- get VistaLink version
18 SET XOBDATA("VL VERSION")=$$GETVAL()
19 ;
20 ; -- get RpcHandler version
21 SET XOBDATA("XOB RPC","RPC HANDLER VERSION")=$$GETVAL()
22 ;
23 ; -- Set basic constant attributes
24 SET XOBDATA("MODE")="singleton"
25 ;
26 ; -- get RPC info from stream
27 IF XOBDATA("XOB RPC","RPC HANDLER VERSION")>1.0 SET X=$$SETVER($$GETVAL())
28 SET XOBDATA("XOB RPC","RPC NAME")=$$GETVAL()
29 SET XOBDATA("XOB RPC","RPC CONTEXT")=$$GETVAL()
30 ;
31 ; -- set RPC time out
32 SET X=$$SETTO^XOBVLIB($$GETVAL())
33 ;
34 ; -- set security info
35 DO SECURITY
36 ;
37 ; -- set RPC parameters
38 DO PARMS
39 ;
40 ; -- read end of text character EOT to empty buffer
41 SET EOT=$$GETSTR(1)
42 QUIT
43 ;
44GETVAL() ; -- get next VALue from stream buffer
45 QUIT $$GETSTR($$GETLEN())
46 ;
47GETLEN() ; -- get the length of the next value
48 IF 'DEBUG QUIT +$$GETSTR(LENSIZE)
49 ; -- Ex. of why 4: VAL=00001
50 QUIT +$PIECE($$GETSTR(LENSIZE+4),"=",2)
51 ;
52GETSTR(LEN) ; -- extracts string of length, LEN, from stream buffer and returns extracted string
53 NEW X
54 FOR QUIT:($LENGTH(XOBUF)'<LEN) DO READ(LEN-$LENGTH(XOBUF))
55 SET X=$EXTRACT(XOBUF,1,LEN)
56 SET XOBUF=$EXTRACT(XOBUF,LEN+1,999)
57 QUIT X
58 ;
59READ(LEN) ; -- read more from stream buffer but only needed amount
60 NEW X
61 FOR QUIT:LEN<512 SET LEN=LEN-511 READ X#511:1 SET XOBUF=XOBUF_X
62 IF LEN>0 READ X#LEN:1 SET XOBUF=XOBUF_X
63 QUIT
64 ;
65 ;
66 ; ---------------- Security Information Processing ----------------
67SECURITY ;
68 ;
69 ; -- if called from VL v1.0 client then set up J2SE defaults
70 IF $GET(XOBDATA("VL VERSION"))="1.0" DO V1 QUIT
71 ;
72 ; -- set security info
73 SET XOBDATA("XOB RPC","SECURITY","TYPE")=$$GETVAL()
74 SET XOBDATA("XOB RPC","SECURITY","DIV")=$$GETVAL()
75 SET XOBDATA("XOB RPC","SECURITY","STATE")=$$GETVAL()
76 ;
77 ; -- get needed type vars if not authenticated
78 IF XOBDATA("XOB RPC","SECURITY","STATE")'="authenticated" DO
79 . DO @($$UP^XLFSTR($GET(XOBDATA("XOB RPC","SECURITY","TYPE"))))
80 ;
81 QUIT
82 ;
83AV ; -- access and verify code type (KAAJEE)
84 SET XOBDATA("XOB RPC","SECURITY","TYPE","AVCODE")=$$GETVAL()
85 QUIT
86 ;
87CCOW ; -- CCOW type (FatKAAT)
88 SET XOBDATA("XOB RPC","SECURITY","TYPE","CCOW")=$$GETVAL()
89 QUIT
90 ;
91DUZ ; -- simple duz type
92 SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
93 QUIT
94 ;
95VPID ; -- vpid type
96 SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
97 QUIT
98 ;
99APPPROXY ; -- application proxy type
100 SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$$GETVAL()
101 QUIT
102 ;
103J2SE ; -- c/s type
104 ; -- this line should never be executed since state will
105 ; always be authenticated ; entered for completeness
106 QUIT
107 ;
108V1 ; -- set up security compatibility for VL v1.0 client
109 ; (tag also called by ELST^XOBRPCI)
110 ;
111 SET XOBDATA("XOB RPC","SECURITY","TYPE")="j2se"
112 SET XOBDATA("XOB RPC","SECURITY","DIV")=""
113 SET XOBDATA("XOB RPC","SECURITY","STATE")="authenticated"
114 QUIT
115 ; --------------------- RPC Paramter Processing -----------------
116PARMS ;
117 ;
118 ; -- get how many parameters to expect
119 SET XOBDATA("XOB RPC","PARAMS")=""
120 SET PCNT=+$$GETVAL()
121 ;
122 ; -- get the parameters
123 IF PCNT>0 FOR CNTP=1:1:PCNT DO
124 . SET TYP=$$GETVAL()
125 . SET POS=+$$GETVAL()
126 . SET XOBPN="XOBP"_POS
127 . SET XOBDATA("XOB RPC","PARAMS",POS)=XOBPN
128 . ;
129 . ; -- get single value
130 . IF TYP'="array" DO QUIT
131 . . ; -- get value for ref type
132 . . IF TYP="ref" SET @XOBPN=@$$GETVAL() QUIT
133 . . ;
134 . . ; -- get value for other non-array types
135 . . SET @XOBPN=$$GETVAL()
136 . ;
137 . ; -- get how many subscripts to expect for an array
138 . SET ICNT=+$$GETVAL()
139 . ;
140 . ; -- set root node of array to ""
141 . SET @XOBPN=""
142 . ;
143 . ; -- get the subscripts and values for the array
144 . IF ICNT>0 FOR CNTI=1:1:ICNT DO
145 . . SET SUB=$$GETVAL()
146 . . SET VAL=$$GETVAL()
147 . . IF $EXTRACT(SUB,1)=$CHAR(13) DO
148 . . . SET @("@XOBPN@("_$EXTRACT(SUB,2,$LENGTH(SUB))_")=VAL")
149 . . ELSE DO
150 . . . SET @XOBPN@(SUB)=VAL
151 ;
152 ; -- build parameter signature for RPC call
153 SET PARAMS="",POS=0
154 FOR SET POS=$ORDER(XOBDATA("XOB RPC","PARAMS",POS)) QUIT:'POS SET PARAMS=PARAMS_",."_XOBDATA("XOB RPC","PARAMS",POS)
155 SET XOBDATA("XOB RPC","PARAMS")=PARAMS
156 ;
157 QUIT
158 ;
159 ; ------------------------------------------------------------------
160 ;
161GETVER() ; -- get rpc version
162 QUIT $GET(XOBDATA("XOB RPC","VERSION"),0)
163 ;
164SETVER(VERSION) ; -- set rpc version
165 SET XOBDATA("XOB RPC","VERSION")=VERSION
166 QUIT 1
167 ;
Note: See TracBrowser for help on using the repository browser.