source: FOIAVistA/trunk/r/RPC_BROKER-XWB/XWBM2MC.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1XWBM2MC ;OIFO-Oakland/REM - M2M Broker Client APIs ;05/21/2002 17:55
2 ;;1.1;RPC BROKER;**28,34**;Mar 28, 1997
3 ;
4 QUIT
5 ;
6 ;p34 -make sure RES is defined - CALLRPC.
7 ; -error exception if RPCNAM not defined - CALLRPC.
8 ; -kill XWBY before going to PARSE^XWBRPC - CALLRPC.
9 ; -return 0 when error occurs and XWBY=error msg - CALLRPC.
10 ; -new module to GET the division for a user - GETDIV.
11 ; -new module to SET the division for a user - SETDIV.
12 ; -kills entry for current context in ^TMP("XWBM2M",$J) - CLEAN.
13 ; -comment out line. Will do PRE in REQUEST^XWBRPCC - PARAM.
14 ; -send PORT;IP to ERROR so it's included in error msg - ERROR.
15 ; -add 2 more error msg for GETDIV and SETDIV - ERRMGS.
16 ;
17CONNECT(PORT,IP,AV) ;Establishes the connection to the server.
18 ;CONNECT returns 1=successful, 0=failed
19 ;PORT - PORT number where listener is running.
20 ;IP - IP address where the listener is running.
21 ;AV - Access and verify codes to sign on into VistA.
22 ;DIV - User division.
23 ;
24 ;K XWBPARMS
25 N XWBSTAT,XWBPARMS
26 S XWBPARMS("ADDRESS")=IP,XWBPARMS("PORT")=PORT
27 S XWBPARMS("RETRIES")=3 ;Retries 3 times to open
28 ;
29 ;p34-send PORT;IP to ERROR so it's included in error msg.
30 I '$$OPEN^XWBRL(.XWBPARMS) D ERROR(1,PORT_";"_IP) Q 0
31 D SAVDEV^%ZISUTL("XWBM2M PORT")
32 ;
33 ;XUS SIGNON SETUP RPC
34 I '$$SIGNON() D ERROR(2) S X=$$CLOSE() Q 0
35 ; Results from XUS Signon
36 ; 1=server name, 2=volume, 3=uci, 4=device, 5=# attempts
37 ; 6=skip signon-screen
38 ;M ^TMP("XWBM2M",$J,"XUS SIGNON")=^TMP("XWBM2MRPC",$J,"RESULTS") ;Remove after testing **REM
39 ;
40 ;Validate AV codes
41 ;S AV=$$CHARCHK^XWBUTL(AV) ;Convert and special char
42 I '$$VALIDAV(AV) D ERROR(3) S X=$$CLOSE() Q 0
43 ;
44 I $G(^TMP("XWBM2MRPC",$J,"RESULTS",1))'>0 D ERROR(4) S X=$$CLOSE() Q 0
45 ;M ^TMP("XWBM2M",$J,"XUS AV CODE")=^TMP("XWBM2MRPC",$J,"RESULTS") ;Remove after testing **REM
46 ;
47 D USE^%ZISUTL("XWBM2M CLIENT") U IO
48 S ^TMP("XWBM2M",$J,"CONNECTED")=1
49 Q 1
50 ;
51ISCONT() ;Function to check connection status. 1=connect, 0=not connect
52 Q $G(^TMP("XWBM2M",$J,"CONNECTED"),0)
53 ;
54SETCONTX(CONTXNA) ;Set context and returns 1=successful or 0=failed
55 N REQ,XWBPARMS,X
56 S ^TMP("XWBM2M",$J,"CONTEXT")=""
57 K ^TMP("XWBM2M",$J,"ERROR","SETCONTX")
58 ;;D PRE,SETPARAM(1,"STRING",$$CHARCHK^XWBUTL($$ENCRYP^XUSRB1(CONTXNA)))
59 D PRE,SETPARAM(1,"STRING",$$ENCRYP^XUSRB1(CONTXNA))
60 S X=$$CALLRPC("XWB CREATE CONTEXT","REQ",1)
61 S REQ=$G(REQ(1))
62 I REQ'=1 S ^TMP("XWBM2ME",$J,"ERROR","SETCONTX")=REQ Q 0
63 S ^TMP("XWBM2M",$J,"CONTEXT")=CONTXNA
64 Q 1
65 ;
66GETCONTX(CONTEXT) ;Returns current context
67 S CONTEXT=$G(^TMP("XWBM2M",$J,"CONTEXT"))
68 I CONTEXT="" Q 0
69 Q 1
70 ;
71SETPARAM(INDEX,TYPE,VALUE) ;Set a Params entry
72 S XWBPARMS("PARAMS",INDEX,"TYPE")=TYPE
73 S XWBPARMS("PARAMS",INDEX,"VALUE")=VALUE
74 Q
75 ;
76PARAM(PARAMNUM,ROOT) ;Build the PARAM data structure
77 ;p34-comment out line. Will do PRE in REQUEST^XWBRPCC
78 ;
79 I PARAMNUM=""!(ROOT="") Q 0
80 ;D PRE ;*p34
81 M XWBPARMS("PARAMS",PARAMNUM)=@ROOT
82 Q 1
83 ;
84CALLRPC(RPCNAM,RES,CLRPARMS) ;Call to RPC and wraps RPC in XML
85 ;RPCNAM -RPC name to run
86 ;RES -location where to place results. If no RES, then results will be
87 ; placed in ^TMP("XWBM2M",$J,"RESULTS")
88 ;CLRPARMS - 1=clear PARAMS, 0=do not clear PARAMS. Default is 1.
89 ;
90 N ER,ERX,GL
91 I '$D(RES) S RES="" ;*p34-make sure RES is defined.
92 I '$D(RPCNAM) D Q 0 ;*p34-error if RPCNAM not defined.
93 .I $G(RES)'="" S @RES="Pass in NULL for RPCNAM."
94 .I $G(RES)="" S ^TMP("XWBM2MRPC",$J,"RESULTS",1)="Pass in NULL for RPCNAM."
95 K ^TMP("XWBM2MRPC",$J,"RESULTS") ;Clear before run new RPC
96 K ^TMP("XWBM2ME",$J,"ERROR","CALLRPC")
97 I '$$ISCONT() D ERROR(5) Q 0 ;Not connected so do not run RPC
98 D SAVDEV^%ZISUTL("XWBM2M CLIENT")
99 D USE^%ZISUTL("XWBM2M PORT") U IO
100 S XWBPARMS("URI")=RPCNAM
101 S XWBCRLFL=0
102 D REQUEST^XWBRPCC(.XWBPARMS)
103 I XWBCRLFL D Q 0
104 . I $G(CLRPARMS)'=0 K XWBPARMS("PARAMS")
105 . K RES
106 . D USE^%ZISUTL("XWBM2M CLIENT") U IO
107 ;
108 ;Check if needed!! **REM
109 ;;IF $G(XWBPARMS("RESULTS"))="" SET XWBPARMS("RESULTS")=$NA(^TMP("XWBRPC"))
110 ;
111 I '$$EXECUTE^XWBVLC(.XWBPARMS) D Q 0 ;Run RPC and place raw XML results
112 .D ERROR(6)
113 .D USE^%ZISUTL("XWBM2M CLIENT") U IO
114 ;
115 S XWBY="" I RES'="" S XWBY=RES K @($G(XWBY)) ;*p34-kill XWBY before PARSE
116 D PARSE^XWBRPC(.XWBPARMS,XWBY)
117 ;
118 ;*p34-return 0 when error occurs and XWBY=error msg.
119 I ($G(RES))'="",($G(@XWBY))="",($G(@(XWBY_"("_1_")")))="" D Q ERX
120 .S ER=$G(^TMP("XWBM2MVLC",$J,"XML",2))
121 .S ERX=$S(ER["ERROR":0,ER["ERRORS":0,ER["error":0,ER["errors":0,1:1)
122 .I 'ERX S @XWBY=ER
123 .D USE^%ZISUTL("XWBM2M CLIENT") U IO
124 ;When RES in not defined.
125 I ($G(RES))="",($G(^TMP("XWBM2MRPC",$J,"RESULTS")))="",($G(^TMP("XWBM2MRPC",$J,"RESULTS",1)))="" D Q ERX
126 .S ER=$G(^TMP("XWBM2MVLC",$J,"XML",2))
127 .S ERX=$S(ER["ERROR":0,ER["ERRORS":0,ER["error":0,ER["errors":0,1:1)
128 .I 'ERX S ^TMP("XWBM2MRPC",$J,"RESULTS",1)=ER
129 .D USE^%ZISUTL("XWBM2M CLIENT") U IO
130 ;
131 I $G(CLRPARMS)'=0 K XWBPARMS("PARAMS") ;Default is to clear
132 D USE^%ZISUTL("XWBM2M CLIENT") U IO
133 Q 1
134 ;
135CLOSE() ;Close connection
136 I '$$ISCONT() D ERROR(5) Q 0 ;Not connected
137 D SAVDEV^%ZISUTL("XWBM2M CLIENT")
138 D USE^%ZISUTL("XWBM2M PORT") U IO
139 D CLOSE^XWBRL
140 D RMDEV^%ZISUTL("XWBM2M PORT")
141 D CLEAN
142 S ^TMP("XWBM2M",$J,"CONNECTED")=0
143 Q 1
144 ;
145CLEAN ;Clean up
146 ;*p34-kills entry for current context in ^TMP("XWBM2M",$J)
147 ;
148 I '$G(XWBDBUG) K XWBPARMS
149 K ^TMP("XWBM2M",$J),^TMP("XWBM2MRPC",$J),^TMP("XWBM2MVLC",$J)
150 K ^TMP("XWBM2MRL"),^TMP("XWBM2ML",$J),^TMP("XWBVLL")
151 K XWBTDEV,XWBTID,XWBVER,XWBCBK,XWBFIRST,XWBTO,XWBQUIT,XWBREAD
152 K XWBRL,XWBROOT,XWBSTOP,XWBX,XWBY,XWBYX,XWBREQ,XWBCOK
153 K XWBCLRFL
154 Q
155 ;
156SIGNON() ;
157 ;Encrpt AV before sending with RPC
158 N XWBPARMS,XWBY
159 K XWBPARMS
160 S XWBPARMS("URI")="XUS SIGNON SETUP"
161 S XWBCRLFL=0
162 D REQUEST^XWBRPCC(.XWBPARMS)
163 I XWBCRLFL Q 0
164 ;
165 ;Check if needed!! **REM
166 ;;IF $G(XWBPARMS("RESULTS"))="" SET XWBPARMS("RESULTS")=$NA(^TMP("XWBRPC",$J,"XML"))
167 ;
168 I '$$EXECUTE^XWBVLC(.XWBPARMS) Q 0 ;Run RPC and place raw XML results in ^TMP("XWBM2MVLC"
169 S XWBY="" D PARSE^XWBRPC(.XWBPARMS,XWBY) ;Parse out raw XML and place results in ^TMP("XWBM2MRPC"
170 Q 1
171 ;
172VALIDAV(AV) ;Check AV code
173 K XWBPARMS
174 S AV=$$ENCRYP^XUSRB1(AV) ;Encrypt access/verify codes
175 D PRE
176 ;
177 ; -String parameter type
178 S XWBPARMS("PARAMS",1,"TYPE")="STRING"
179 ;;S XWBPARMS("PARAMS",1,"VALUE")=$$CHARCHK^XWBUTL(AV)
180 S XWBPARMS("PARAMS",1,"VALUE")=AV
181 S XWBPARMS("URI")="XUS AV CODE"
182 S XWBCRLFL=0
183 D REQUEST^XWBRPCC(.XWBPARMS)
184 I XWBCRLFL Q 0
185 ;
186 ;Check if needed!! **REM
187 ;;IF $G(XWBPARMS("RESULTS"))="" SET XWBPARMS("RESULTS")=$NA(^TMP("XWBRPC",$J,"XML"))
188 ;
189 I '$$EXECUTE^XWBVLC(.XWBPARMS) Q 0 ;Run RPC and place raw XML results in ^TMP("XWBM2MVLC"
190 S XWBY="" D PARSE^XWBRPC(.XWBPARMS,XWBY) ;Parse out raw XML and place results in ^TMP("XWBM2MRPC"
191 K XWBPARMS
192 Q 1
193 ;
194GETDIV(XWBDIVG) ;*p34-gets the division for a user.
195 ;Returns 1-succuss, 0=fail
196 ;XWBDIVG - where the division string will be places.
197 ;Return value for XWBDIVG:
198 ; XWBDIVG(1)=number of divisions
199 ; XWBDIVG(#)='ien;station name;station#' delimitated with ";"
200 ; If a user has only 1 divison, then XWBDIVG(1)=0 because Kernel
201 ; will automatically assign that division as a default. Use IEN to
202 ; set division in $$SETDIV.
203 N RPC,ROOT
204 K XWBPARMS
205 D PRE,SETPARAM(1,"STRING","DUMBY")
206 I '$$CALLRPC^XWBM2MC("XUS DIVISION GET",XWBDIVG,0) D ERROR(10) Q 0
207 K XWBPARMS
208 Q 1
209 ;
210SETDIV(XWBDIVS) ;*p34-sets the division for a user.
211 ;Returns 1-success, 0=fail
212 ;XWBDIVS - Division to set. Use IEN from $$GETDIV.
213 N REQ
214 K XWBPARMS
215 S REQ="RESULT"
216 D PRE,SETPARAM(1,"STRING",XWBDIVS)
217 I '$$CALLRPC^XWBM2MC("XUS DIVISION SET",REQ,0) D ERROR(11) Q 0
218 K XWBPARMS
219 Q 1
220 ;
221PRE ;Prepare the needed PARMS **REM might not need PRE
222 ;S XWBCON="DSM" ;Check if needed!! **REM
223 ;
224 S XWBPARMS("MODE")="RPCBroker"
225 Q
226 ;
227ERROR(CODE,STR) ;Will write error msg and related API in TMP
228 ;*p34-new STR to append to error msg.
229 N API,X
230 S API=$P($T(ERRMSG+CODE),";;",3)
231 S X=$NA(^TMP("XWBM2ME",$J,"ERROR",API)),@X=$P($T(ERRMSG+CODE),";;",2)_$G(STR) ;*p34
232 Q
233 ;
234ERRMSG ; Error messages
235 ;*p34-add 2 more error msg for GETDIV and SETDIV.
236 ;;Could not open connection ;;CONNECT
237 ;;XUS SIGNON SETUP RPC failed ;;SIGNON
238 ;;XUS AV CODE RPC failed ;;SIGNON
239 ;;Invalid user, no DUZ returned ;;SIGNON
240 ;;There is no connection ;;CALLRPC
241 ;;RPC could not be processed ;;CALLRPC
242 ;;Remote Procedure Unknown ;;SERVER
243 ;;Control Character Found ;;CALLRPC
244 ;;Error in division return ;;CONNECT
245 ;;Could not obtain list of valid divisions for current user ;;GETDIV
246 ;;Could not Set active Division for current user ;;SETDIV
247 Q
Note: See TracBrowser for help on using the repository browser.