source: FOIAVistA/trunk/r/RPC_BROKER-XWB/XWBBRK.m@ 635

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

initial load of FOIAVistA 6/30/08 version
File size: 6.2 KB
Line 
1XWBBRK ;ISC-SF/EG - DHCP BROKER PROTOYPE ;07/08/2004 11:08
2 ;;1.1;RPC BROKER;**2,4,10,16,26,35**;Mar 28, 1997
3PRSP(P) ;Parse Protocol
4 ;M Extrinsic Function
5 ;
6 ;Inputs
7 ;P Protocol string with the form
8 ; Protocol := Protocol Header^Message where
9 ; Protocol Header := LLLWKID;WINH;PRCH;WISH;MESG
10 ; LLL := length of protocol header (3 numeric)
11 ; WKID := Workstation ID (ALPHA)
12 ; WINH := Window handle (ALPHA)
13 ; PRCH := Process handle (ALPHA)
14 ; WISH := Window server handle (ALPHA)
15 ; MESG := Unparsed message
16 ;Outputs
17 ;ERR 0 for success, "-1^Text" if error
18 ;
19 N ERR,C,M,R,X,U
20 S U="U",R=0,C=";",ERR=0,M=512 ;Maximum buffer input
21 IF $E(P,1,5)="{XWB}" S P=$E(P,6,$L(P)) ;drop out prefix
22 IF '+$G(P) S ERR="-1^Required input reference is NULL"
23 IF +ERR=0 D
24 . S XWB(R,"LENG")=+$E(P,1,3)
25 . S X=$E(P,4,XWB(R,"LENG")+3)
26 . S XWB(R,"MESG")=$E(P,XWB(R,"LENG")+4,M)
27 . S XWB(R,"WKID")=$P(X,C)
28 . S XWB(R,"WINH")=$P(X,C,2)
29 . S XWB(R,"PRCH")=$P(X,C,3)
30 . S XWB(R,"WISH")=$P(X,C,4)
31 Q ERR
32 ;
33PRSM(P) ;Parse message
34 ;M Extrinsic Function
35 ;
36 ;Inputs
37 ;P Message string with the form
38 ; Message := Header^Content
39 ; Header := LLL;FLAG
40 ; LLL := length of entire message (3 numeric)
41 ; FLAG := 1 indicates variables follow
42 ; Content := Contains API call information
43 ;Outputs
44 ;ERR 0 for success, "-1^Text" if error
45 N C,ERR,M,R,X,U
46 S U="^",R=1,C=";",ERR=0,M=512 ;Max buffer
47 IF '+$G(P) S ERR="-1^Required input reference is NULL"
48 IF +ERR=0 D
49 . S XWB(R,"LENG")=+$E(P,1,5)
50 . S XWB(R,"FLAG")=$E(P,6,6)
51 . S XWB(R,"TEXT")=$E(P,7,M)
52 Q ERR
53 ;
54PRSA(P) ;Parse API information, get calling info
55 ;M Extrinsic Function
56 ;Inputs
57 ;P Content := API Name^Param string
58 ; API := .01 field of API file
59 ; Param := Parameter information
60 ;Outputs
61 ;ERR 0 for success, "-1^Text" if error
62 ;
63 N C,DR,ERR,M,R,T,X,U
64 S U="^",R=2,C=";",ERR=0,M=512 ;Max buffer
65 IF '+$L(P) S ERR="-1^Required input reference is NULL"
66 IF +ERR=0 D
67 . S XWB(R,"CAPI")=$P(P,U)
68 . S XWB(R,"PARM")=$E(P,$F(P,U),M)
69 . S T=$O(^XWB(8994,"B",XWB(R,"CAPI"),0))
70 . I '+T S ERR="-1^Remote Procedure '"_XWB(R,"CAPI")_"' doesn't exist on the server." Q ;P10 - dpc
71 . S T(0)=$G(^XWB(8994,T,0))
72 . I $P(T(0),U,6)=1!($P(T(0),U,6)=2) S ERR="-1^Remote Procedure '"_XWB(R,"CAPI")_"' cannot be run at this time." Q ;P10. Check INACTIVE field. - dpc.
73 . S XWB(R,"NAME")=$P(T(0),"^")
74 . S XWB(R,"RTAG")=$P(T(0),"^",2)
75 . S XWB(R,"RNAM")=$P(T(0),"^",3)
76 . S XWBPTYPE=$P(T(0),"^",4)
77 . S XWBWRAP=+$P(T(0),"^",8)
78 Q ERR
79 ;
80PRSB(P) ;Parse Parameter information
81 ;M Extrinsic Function
82 ;Inputs
83 ;P Param := M parameter list
84 ; Param := LLL,Name,Value
85 ; LLL := length of variable name and value
86 ; Name := name of M variable
87 ; Value := a string
88 ;Outputs
89 ;ERR 0 for success, "-1^Text" if error
90 ;
91 N A,ERR,F,FL,I,K,L,M,P1,P2,P3,P4,P5,MAXP,R
92 S R=3,MAXP=+$E(P,1,5)
93 S P1=$E(P,6,MAXP+5) ;only param string
94 S ERR=0,F=3,M=512
95 IF '+$D(P) S ERR="-1^Required input reference is NULL"
96 S FL=+$G(XWB(1,"FLAG"))
97 S I=0
98 IF '+ERR D
99 . ;IF 'FL S P1=$E(P,F+1,MAXP) Q
100 . IF 'FL,+MAXP=0 S P1="",ERR=1 Q
101 . F D Q:P1=""
102 . . Q:P1=""
103 . . S L=+$E(P1,1,3)-1
104 . . S P3=+$E(P1,4,4)
105 . . S P1=$E(P1,5,MAXP)
106 . . S XWB(R,"P",I)=$S(P3'=1:$E(P1,1,L),1:$$GETV($E(P1,1,L)))
107 . . IF FL=1,P3=2 D ;XWB*1.1*2
108 . . . S A=$$OARY^XWBBRK2,XWBARY=A
109 . . . S XWB(R,"P",I)=$$CREF^XWBBRK2(A,XWB(R,"P",I))
110 . . S P1=$E(P1,L+1,MAXP)
111 . . S K=I,I=I+1
112 . IF 'FL Q
113 . S P3=P
114 . S L=+$E(P3,1,5)
115 . S P1=$E(P3,F+3,L+F)
116 . ;IF FL=1 S P1=$$CREF^XWBBRK2(A,P1) ;convert array ref to namespace ref
117 . S P2=$E(P3,L+F+3,M)
118 . ;instantiate array
119 . ;S DM=0
120 . F D Q:+L=0
121 . . ;Sumtimes the array is null, so there isn't data for first read.
122 . . S L=+$$BREAD^XWBRW(3,15,1) Q:L=0 S P3=$$BREAD^XWBRW(L)
123 . . S L=+$$BREAD^XWBRW(3) IF L'=0 S P4=$$BREAD^XWBRW(L)
124 . . IF L=0 Q
125 . . IF P3=0,P4="" S L=0 Q ; P4=0 changed to P4="" JLI 021114
126 . . IF FL=1 D LINST(A,P3,P4)
127 . . IF FL=2 D GINST
128 IF ERR Q P1
129 S P1=""
130 D Q P1
131 . F I=0:1:K D
132 . . IF FL,$E(XWB(R,"P",I),1,5)=".XWBS" D Q ;XWB*1.1*2
133 . . . S P1=P1_"."_$E(XWB(R,"P",I),2,$L(XWB(R,"P",I)))
134 . . . IF I'=K S P1=P1_","
135 . . S P1=P1_"XWB("_R_",""P"","_I_")"
136 . . IF I'=K S P1=P1_","
137 IF '+ERR Q P1
138 Q ERR
139 ;
140CALLP(XWBP,P,DEBUG) ;make API call using Protocol string
141 ;ERR will be 0 or "-1^text"
142 N ERR,S
143 S ERR=0
144 IF '$D(DEBUG) S DEBUG=0
145 ;IF 'DEBUG D:$D(XRTL) T0^%ZOSV ;start RTL
146 S ERR=$$PRSP(P)
147 IF '+ERR S ERR=$$PRSM(XWB(0,"MESG"))
148 IF '+ERR S ERR=$$PRSA(XWB(1,"TEXT")) I $G(XWB(2,"CAPI"))="XUS SET SHARED" S XWBSHARE=1 Q
149 I +ERR S XWBSEC=$P(ERR,U,2) ;P10 -- dpc
150 IF '+ERR S S=$$PRSB(XWB(2,"PARM"))
151 ;Check OK
152 I '+ERR D CHKPRMIT^XWBSEC(XWB(2,"CAPI")) ;checks if RPC allowed to run
153 S:$L($G(XWBSEC)) ERR="-1^"_XWBSEC
154 ;IF 'DEBUG S:$D(XRT0) XRTN="RPC BROKER READ/PARSE" D:$D(XRT0) T1^%ZOSV ;stop RTL
155 IF '+ERR,(+S=0)!(+S>0) D
156 . ;Logging
157 . I $G(XWBDEBUG)>1 D LOG^XWBDLOG("RPC: "_XWB(2,"CAPI"))
158 . D CAPI^XWBBRK2(.XWBP,XWB(2,"RTAG"),XWB(2,"RNAM"),S)
159 E D CLRBUF ;p10
160 IF 'DEBUG K XWB
161 IF $D(XWBARY) K @XWBARY,XWBARY
162 Q
163 ;
164LINST(A,X,XWBY) ;instantiate local array
165 IF XWBY=$C(1) S XWBY=""
166 S X=A_"("_X_")"
167 S @X=XWBY
168 Q
169GINST ;instantiate global
170 N DONE,N,T,T1
171 S (DONE,I)=0
172 ;find piece with global ref - recover $C(44)
173 S REF=$TR(REF,$C(23),$C(44))
174 F D Q:DONE
175 . S N=$NA(^TMP("XWB",$J,$P($H,",",2)))
176 . S XWB("FRM")=REF
177 . S XWB("TO")=N
178 . IF '$D(@N) S DONE=1 Q
179 ;loop through all and instantiate
180 S DONE=0
181 F D Q:DONE
182 . S T=$E(@REF@(I),4,M)
183 . IF T="" S DONE=1 Q
184 . S @N@("XWB")="" ;set naked indicator
185 . S @T
186 . S I=I+1
187 K @N@("XWB")
188 Q
189 ;
190GETV(V) ;get value of V - reference parameter
191 N X
192 S X=V
193 IF $E(X,1,2)="$$" Q ""
194 IF $C(34,36)[$E(V) X "S V="_$$VCHK(V)
195 E S V=@V
196 Q V
197 ;
198VCHK(S) ;Parse string for first argument
199 N C,I,P
200 F I=1:1 S C=$E(S,I) D VCHKP:C="(",VCHKQ:C=$C(34) Q:" ,"[C
201 Q $E(S,1,I-1)
202VCHKP S P=1 ;Find closing paren
203 F I=I+1:1 S C=$E(S,I) Q:P=0!(C="") I "()"""[C D VCHKQ:C=$C(34) S P=P+$S("("[C:1,")"[C:-1,1:0)
204 Q
205VCHKQ ;Find closing quote
206 F I=I+1:1 S C=$E(S,I) Q:C=""!(C=$C(34))
207 Q
208CLRBUF ;p10 Empties Input buffer
209 N %
210 F R %#1:XWBTIME(1) Q:%=""
211 Q
Note: See TracBrowser for help on using the repository browser.