Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

_ZMGWSIS.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago
initial load of WorldVistAEHR
File size: 32.4 KB

Line
1	%ZMGWSIS ; Service Integration - Child Process
2	;
3	; ----------------------------------------------------------------------------
4	; \| m_apache \|
5	; \| Copyright (c) 2004-2009 M/Gateway Developments Ltd, \|
6	; \| Surrey UK. \|
7	; \| All rights reserved. \|
8	; \| \|
9	; \| http://www.mgateway.com \|
10	; \| \|
11	; \| This program is free software: you can redistribute it and/or modify \|
12	; \| it under the terms of the GNU Affero General Public License as \|
13	; \| published by the Free Software Foundation, either version 3 of the \|
14	; \| License, or (at your option) any later version. \|
15	; \| \|
16	; \| This program is distributed in the hope that it will be useful, \|
17	; \| but WITHOUT ANY WARRANTY; without even the implied warranty of \|
18	; \| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the \|
19	; \| GNU Affero General Public License for more details. \|
20	; \| \|
21	; \| You should have received a copy of the GNU Affero General Public License \|
22	; \| along with this program. If not, see <http://www.gnu.org/licenses/>. \|
23	; ----------------------------------------------------------------------------
24	;
25	A0 D VERS Q
26	;f i=1:1:10000 s x=$$esize(.y,i,62),z=$$dsize(y,$l(y),62) w !,i,?10,y,?20,z
27	q
28	;
29	V() ; Version and date
30	N V,R,D
31	S V="2.0"
32	S R=6
33	S D="17 February 2009"
34	Q V_"."_R_"."_D
35	;
36	VERS ; Version information
37	N V
38	S V=$$V()
39	W !,"M/Gateway Developments Ltd - Service Integration Gateway"
40	W !,"Version: "_$P(V,".",1,2)_"; Revision "_$P(V,".",3)_" ("_$P(V,".",4)_")"
41	W !
42	Q
43	;
44	VARS ; Public system variables
45	;
46	; The following variables can be modified in accordance with the documentation
47	s extra=$c(1) ; Key marker for oversize data strings
48	s abyref=0 ; Set to 1 to treat all arrays as if they were passed by reference
49	s mqinfo=0 ; Set to 1 to place all MQ error/information messages in %mgwmq("info")
50	; Otherwise, error messages will be placed in %mgwmq("error")
51	; and 'information only' messages in %mgwmq("info")
52	;
53	; The following variables must not be modified
54	i '($d(global)#10) s global=0
55	i '($d(oversize)#10) s oversize=0
56	i '($d(offset)#10) s offset=0
57	i '($d(version)#10) s version=+$$V()
58	; #define MGW_TX_DATA 0
59	; #define MGW_TX_AKEY 1
60	; #define MGW_TX_AREC 2
61	; #define MGW_TX_EOD 3
62	s ddata=0,dakey=1,darec=2,deod=3
63	q
64	;
65	esize(esize,size,base)
66	n i,x
67	i base'=10 g esize1
68	s esize=size
69	q $l(esize)
70	esize1 ; Up to base 62
71	s esize=$$ebase62(size#base)
72	f i=1:1 s x=(size\(base**i)) q:'x s esize=$$ebase62(x#base)_esize
73	q $l(esize)
74	;
75	dsize(esize,len,base)
76	n i,x
77	i base'=10 g dsize1
78	s size=+$e(esize,1,len)
79	q size
80	dsize1 ; Up to base 62
81	s size=0
82	f i=len:-1:1 s x=$e(esize,i) s size=size+($$dbase62(x)(base*(len-i)))
83	q size
84	;
85	ebase62(n10) ; Encode to single digit (up to) base-62 number
86	i n10'<0,n10<10 q $c(48+n10)
87	i n10'<10,n10<36 q $c(65+(n10-10))
88	i n10'<36,n10<62 q $c(97+(n10-36))
89	q ""
90	;
91	dbase62(nxx) ; Decode single digit (up to) base-62 number
92	n x
93	s x=$a(nxx)
94	i x'<48,x<58 q (x-48)
95	i x'<65,x<91 q ((x-65)+10)
96	i x'<97,x<123 q ((x-97)+36)
97	q ""
98	;
99	ehead(head,size,byref,type)
100	s slen=$$esize(.esize,size,10)
101	s code=slen+(type8)+(byref64)
102	s head=$c(code)_esize
103	s hlen=slen+1
104	q hlen
105	;
106	dhead(head,size,byref,type)
107	s code=$a(head,1)
108	s byref=code\64
109	s type=(code#64)\8
110	s slen=code#8
111	s hlen=slen+1
112	s size=0 i $l(head)'<hlen s size=$$dsize($e(head,2,slen+1),slen,10)
113	q hlen
114	;
115	rdxx(len) ; Read 'len' Bytes from MGWSI
116	n x,nmax,n,ncnt
117	i 'len q ""
118	s x="",nmax=len,n=0,ncnt=0 f r y#nmax d q:'nmax i ncnt>100 q
119	. i y="" s ncnt=ncnt+1 q
120	. s ncnt=0,x=x_y,n=n+$l(y),nmax=len-n
121	. q
122	i ncnt s x="" d HALT ; Client disconnect
123	q x
124	;
125	rdx(len,clen,rlen) ; Read from MGWSI - Initialize: (rdxsize,rdxptr,rdxrlen)=0,rdxbuf="",maxlen=$$getslen()
126	n result,get,avail
127	;
128	;s result="" f get=1:1:len r *x s result=result_$c(x)
129	;s rlen=rlen+len q result
130	;
131	s get=len,result=""
132	i 'len q result
133	f d i 'get q
134	. s avail=rdxsize-rdxptr
135	. ;d EVENT("i="_i_";len="_len_";avail="_avail_";get="_get_"=("_rdxbuf_") "_CLEN_" "_RLEN)
136	. i get'>avail s result=result_$e(rdxbuf,rdxptr+1,rdxptr+get),rdxptr=rdxptr+get,get=0 q
137	. s result=rdxbuf,rdxptr=0,get=get-avail
138	. s avail=clen-rdxrlen i 'avail q
139	. i avail>maxlen s avail=maxlen
140	. s rdxbuf=$$rdxx(avail),rdxsize=avail,rdxptr=0,rdxrlen=rdxrlen+avail
141	. ;d EVENT("rdxbuf="_i_"="_rdxbuf)
142	. q
143	s rlen=rlen+len
144	q result
145	;
146	CHILD(pport,port,conc,uci) ; Child
147	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":CHILDE"
148	i uci'="" D UCI(uci)
149	i 'conc d
150	. s ^%MGWSI("TCP_PORT",pport,port)=$j
151	. Set dev="server$"_$j,timeout=30
152	. ; Open TCP server device
153	. Open dev:(ZLISTEN=port_":TCP":attach="server"):timeout:"SOCKET"
154	. Use dev
155	. Write /listen(1)
156	. set %ZNSock="",%ZNFrom=""
157	. S OK=1 F D Q:OK I $D(^%MGWSI("STOP")) S OK=0 Q
158	. . Write /wait(timeout)
159	. . I $KEY'="" S OK=1 Q
160	. . d EVENT^%ZMGWSIS("Write /wait(timeout) expires")
161	. . S OK=0
162	. . Q
163	. I 'OK C dev H
164	. set %ZNSock=$piece($KEY,"\|",2),%ZNFrom=$piece($KEY,"\|",3)
165	. ;d EVENT^%ZMGWSIS("Incoming child connection from "_%ZNFrom_" ("_%ZNSock_")")
166	. q
167	;
168	s nato=0
169	CHILD2 ; Child request loop
170	d VARS
171	k ^%MGW("MPC",$J),^MGWSI($J)
172	f i=1:1:37 k @("req"_i)
173	k req s argc=1,array=0
174	i '($d(nato)#10) s nato=0
175	CHILD3 ; Read Request
176	;d EVENT("***** GET NEXT REQUEST *****")
177	s maxlen=$$getslen()
178	s (rdxsize,rdxptr,rdxrlen)=0,rdxbuf=""
179	s sn=0,sl=0,ok=1,type=0,offset=0,var="req"_argc,req(argc)=var,(cmnd,pcmnd,buf)=""
180	i 'nato r *x
181	i nato r *x:nato i '$T D HALT ; No-activity timeout
182	i x=0 D HALT ; Client disconnect
183	s buf=$c(x) f r *x q:x=10!(x=0) s buf=buf_$c(x)
184	i x=0 D HALT ; Client disconnect
185	s type=0,byref=0 d REQ1 s @var=buf
186	s cmnd=$p(buf,"^",2)
187	S HLEN=$L(buf),CLEN=0
188	I cmnd="P" S CLEN=$$dsize($E(buf,HLEN-(5-1),HLEN),5,62)
189	s %ZCS("client")=$E(buf,4)
190	;d EVENT("request size="_CLEN_" ("_$E(buf,HLEN-(5-1),HLEN)_"); client="_%ZCS("client")_" ;header = "_buf)
191	s RLEN=0
192	I CLEN D REQ
193	;
194	;f i=1:1:argc d EVENT("arg "_i_" = "_$g(@req(i)))
195	;
196	s req=$g(@req(1)) i req="" G CHILD2
197	s cmnd=$p(req,"^",2)
198	k res s res="" s res(1)="00000cv"_$C(10)
199	i cmnd="A" D AYT
200	i cmnd="S" D DINT
201	i cmnd="P" D MPHP
202	i cmnd="H" D INFO
203	i cmnd="X" D HALT
204	D END
205	k res s res=""
206	G CHILD2
207	;
208	CHILDE ; Error
209	d EVENT($ZS)
210	i $ZS["READ" g HALT
211	G CHILD2
212	;
213	HALT ; Halt
214	i 'conc d
215	. ; Close TCP server device
216	. i $l($g(dev)) c dev
217	. s x="" f s x=$o(^%MGWSI("TCP_PORT",x)) q:x="" k ^%MGWSI("TCP_PORT",x,port)
218	. q
219	h
220	;
221	REQ ; Read request data
222	n dev,get,got
223	REQ0 ; Get next argument
224	s x=$$rdx(1,CLEN,.RLEN),hlen=$$dhead(x,.size,.byref,.type)
225	;d EVENT("(1) CLEN="_CLEN_";RLEN="_RLEN_";hlen="_hlen_";argc="_argc_";size="_size_";byref="_byref_";type="_type)
226	s slen=hlen-1
227	s esize=$$rdx(slen,CLEN,.RLEN)
228	s size=$$dsize(esize,slen,10)
229	;d EVENT("(2) CLEN="_CLEN_";RLEN="_RLEN_";hlen="_hlen_";slen="_slen_";argc="_argc_";size="_size_";byref="_byref_";type="_type)
230	s argc=argc+1
231	d REQ1
232	i type=darec d ARRAY G REQZ
233	s got=0 f sn=0:1 s get=size-got s:get>maxlen get=maxlen s buf=$$rdx(get,CLEN,.RLEN) d i got=size q
234	. s got=got+get
235	. ;d EVENT("(3) Data: CLEN="_CLEN_";RLEN="_RLEN_";size="_size_";get="_get_";sn="_sn_";pcmnd="_pcmnd_";buf="_buf)
236	. i argc=3,pcmnd="h" s @var=buf d MPC q
237	. i 'sn s @var=buf q
238	. i sn s @(var_"(extra,sn)")=buf q
239	. q
240	REQZ ; Argument read
241	i RLEN<CLEN G REQ0
242	s eod=1
243	q
244	;
245	REQ1 ; Initialize next argument
246	i argc=1 d
247	. s cmnd=$p(buf,"^",2)
248	. s sysp=$p(buf,"^",3)
249	. s uci=$p(sysp,"#",2) i uci'="" d
250	. . s ucic=$$getuci()
251	. . i ucic'="",uci=ucic q
252	. . D UCI(uci) D EVENT("Correct NameSpace from '"_ucic_"' to '"_uci_"'")
253	. . q
254	. s offset=$p(sysp,"#",3)+0
255	. s global=$p(sysp,"#",7)+0
256	. s pcmnd=$p(buf,"^",4)
257	. q
258	s sn=0,sl=0
259	s var="req"_argc
260	s req(argc)=var
261	s req(argc,0)=type i type=darec s req(argc,0)=1
262	s req(argc,1)=byref
263	i type=1,abyref=1 s req(argc,1)=1
264	q
265	;
266	MPC ; Raw content for HTTP POST: save section of data
267	s sn=sn+1,^%MGW("MPC",$J,"CONTENT",sn)=buf,buf="",sl=0
268	q
269	;
270	ARRAY ; Read array
271	n x,kn,val,sn,ext,get,got
272	;d EVENT("* array *")
273	k x,ext s kn=0
274	ARRAY0 ; Read next element (key or data)
275	s sn=0,sl=0
276	s x=$$rdx(1,CLEN,.RLEN),hlen=$$dhead(x,.size,.byref,.type)
277	;d EVENT("(1) Array CLEN="_CLEN_";RLEN="_RLEN_";hlen="_hlen_";argc="_argc_";size="_size_";byref="_byref_";type="_type)
278	s slen=hlen-1
279	s esize=$$rdx(slen,CLEN,.RLEN)
280	s size=$$dsize(esize,slen,10)
281	;d EVENT("(2) Array CLEN="_CLEN_";RLEN="_RLEN_";hlen="_hlen_";slen="_slen_";argc="_argc_";size="_size_";byref="_byref_";type="_type)
282	i type=deod q
283	s got=0 f sn=0:1 s get=size-got s:get>maxlen get=maxlen s buf=$$rdx(get,CLEN,.RLEN) d i got=size q
284	. s got=got+get
285	. ;d EVENT("(3) Array Data CLEN="_CLEN_";RLEN="_RLEN_";size="_size_";get="_get_";sn="_sn_";pcmnd="_pcmnd_";buf="_buf)
286	. i argc=3,pcmnd="h" s @var=buf d MPC q
287	. i type=dakey s kn=kn+1,x(kn)=buf
288	. i type=ddata s val=buf D ARRAY1 k x,ext s kn=0
289	. q
290	g ARRAY0
291	;
292	ARRAY1 ; Read array - Set a single node
293	n n,i,ref,com,key
294	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":ARRAY1E"
295	s (key,com)="" f i=1:1:kn q:i=kn&($g(x(i))=" ") s key=key_com_"x("_i_")",com=","
296	i global d
297	. i $l(key) s ref="^MGWSI($j,argc-2,"_key_")",eref="^MGWSI($j,argc-2,"_key_",extra,sn)"
298	. i '$l(key) s ref="^MGWSI($j,argc-2)",eref="^MGWSI($j,argc-2,extra,sn)"
299	. q
300	i 'global d
301	. i $l(key) s ref=req(argc)_"("_key_")",eref=req(argc)_"("_key_",extra,sn)"
302	. i '$l(key) s ref=req(argc),eref=req(argc)_"(extra,sn)"
303	. q
304	i $l(ref) x "s "_ref_"=val"
305	f sn=1:1 q:'$d(ext(sn)) x "s "_eref_"=ext(sn)"
306	Q
307	ARRAY1E ;
308	d EVENT("Array: "_$ZS)
309	Q
310	;
311	END ; Terminate Response
312	n len,len62,i,head,x
313	i $e($g(res(1)),6,7)="sc" w $p(res(1),"0",1) D FLUSH q ; Streamed response
314	s len=0
315	f i=1:1 q:'$d(res(i)) s len=len+$l(res(i))
316	s len=len-8
317	s head=$e($g(res(1)),1,8)
318	s x=$$esize(.len62,len,62)
319	f q:$l(len62)'<5 s len62="0"_len62
320	s head=len62_$e(head,6,8) i $l(head)'=8 s head=len62_"cv"_$c(10)
321	s res(1)=head_$e($g(res(1)),9,99999)
322	; Flush the lot out
323	f i=1:1 q:'$d(res(i)) w res(i)
324	D FLUSH
325	Q
326	;
327	FLUSH ; Flush output buffer
328	;w *-3
329	;w *1
330	q
331	;
332	AYT ; Are you there?
333	S req=$g(@req(1))
334	s txt=$p($h,",",2)
335	f q:$l(txt)'<5 s txt="0"_txt
336	s txt="m"_txt
337	f q:$l(txt)'<12 s txt=txt_"0"
338	d send(txt)
339	q
340	;
341	DINT ; Initialise the service link
342	N port,dev,conc,%uci
343	S req=$p($g(@req(1)),"^S^",2,9999)
344	;"^S^version=%s&timeout=%d&nls=%s&uci=%s"
345	S version=$p($p(req,"version=",2),"&",1)
346	S nato=+$p($p(req,"timeout=",2),"&",1)
347	S %ZCS("NLS_TRANS")=$p($p(req,"nls=",2),"&",1)
348	S %UCI=$p($p(req,"uci=",2),"&",1)
349	I $L(%UCI) D UCI(%UCI)
350	S x=$$setio(%ZCS("NLS_TRANS"))
351	S %UCI=$$getuci()
352	s systype=$$getsys()
353	s txt="pid="_$J_"&uci="_%UCI_"&server_type="_systype_"&version="_$p($$V(),".",1,3)_"&child_port=0"
354	d send(txt)
355	q
356	;
357	UCI(UCI) ; Change NameSpace/UCI
358	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":UCIE"
359	i UCI="" Q
360	s $ZG=UCI
361	Q
362	UCIE ; Error
363	d EVENT("UCI Error: "_UCI_" : "_$ZS)
364	q
365	;
366	INFO ; Connection Info
367	n port,dev,conc,nato
368	d send("HTTP/1.1 200 OK"_$Char(13,10)_"Connection: close"_$Char(13,10)_"Content-type: text/html"_$Char(13,10,13,10))
369	d send("<html><head><title>MGWSI - Connection Test</title></head><body bgcolor=#ffffcc>")
370	d send("<h2>MGWSI - Connection Test Successful</h2>")
371	d send("<table border=1>")
372	d send("<tr><td>"_$$getsys()_" Version:</td><td><b>"_$ZV_"<b><tr>")
373	d send("<tr><td>UCI:</td><td><b>"_$$getuci()_"<b><tr>")
374	d send("</table>")
375	d send("</body></html>")
376	q
377	;
378	EVENT(TEXT) ; Log M-Side Event
379	N port,dev,conc,N,EMAX
380	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":EVENTE"
381	F I=1:1 S X=$E(TEXT,I) Q:X="" S Y=$S(X=$C(13):"\r",X=$C(10):"\n",1:"") I Y'="" S $E(TEXT,I)=Y
382	S EMAX=100 ; Maximum log size (No. messages)
383	L +^%MGWSI("LOG")
384	S N=$G(^%MGWSI("LOG")) I N="" S N=0
385	S N=N+1,^%MGWSI("LOG")=N
386	L -^%MGWSI("LOG")
387	S ^%MGWSI("LOG",N,0)=$$HEAD(),^%MGWSI("LOG",N,1)=$E(TEXT,1,230)
388	F N=N-EMAX:-1 Q:'$D(^%MGWSI("LOG",N)) K ^(N)
389	Q
390	EVENTE ; Error
391	Q
392	;
393	DDATE(DATE) ; Decode M date
394	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":DATEE"
395	Q $ZD(DATE,2)
396	DDATEE ; No $ZD Function
397	Q DATE
398	;
399	DTIME(TIME) ; Decode M Time
400	Q (TIME\3600)_":"_(TIME#3600\60)
401	;
402	HEAD() ; Format Header record
403	N %UCI
404	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":HEADE"
405	s %UCI=$$getuci()
406	HEADE ; Error
407	Q $$DDATE(+$H)_" at "_$$DTIME($P($H,",",2))_"~"_$G(%ZCS("PORT"))_"~"_%UCI
408	;
409	HMACSHA256(string,key,b64,context) ; HMAC-SHA256
410	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-SHA256",string,key,b64,context)
411	;
412	HMACSHA1(string,key,b64,context) ; HMAC-SHA1
413	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-SHA1",string,key,b64,context)
414	;
415	HMACSHA(string,key,b64,context) ; HMAC-SHA
416	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-SHA",string,key,b64,context)
417	;
418	HMACMD5(string,key,b64,context) ; HMAC-MD5
419	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-MD5",string,key,b64,context)
420	;
421	SHA256(string,b64,context) ; SHA256
422	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA256",string,"",b64,context)
423	;
424	SHA1(string,b64,context) ; SHA1
425	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA1",string,"",b64,context)
426	;
427	SHA(string,b64,context) ; SHA
428	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA",string,"",b64,context)
429	;
430	MD5(string,b64,context) ; MD5
431	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"MD5",string,"",b64,context)
432	;
433	B64(string,context) ; BASE64
434	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"B64",string,"",0,context)
435	;
436	DB64(string,context) ; DECODE BASE64
437	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"D-B64",string,"",0,context)
438	;
439	TIME(context) ; TIME
440	Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"TIME","","",0,context)
441	;
442	ZTS(context) ; ZTS
443	S TIME=$$TIME(context)
444	S ZTS=$P($H,",",1)_","_(($P(TIME,":",1)6060)+($P(TIME,":",2)*60)+$P(TIME,":",3))
445	Q ZTS
446	;
447	CRYPT(IP,PORT,METHOD,string,key,b64,context)
448	n %mgwmq,response,method
449	s method=METHOD i b64 s method=method_"-B64"
450	s %mgwmq("send")=string
451	s %mgwmq("key")=key
452	i context=0 s response=$$WSMQ(IP,PORT,method,.%mgwmq)
453	i context=1 s response=$$WSX(IP,PORT,method,.%mgwmq)
454	Q $G(%mgwmq("recv"))
455	;
456	WSMQ(IP,PORT,REQUEST,%mgwmq) ; Message for WebSphere MQ (Parameters passed by reference)
457	Q $$WSMQ1(IP,PORT,REQUEST)
458	;
459	WSMQ1(IP,PORT,REQUEST) ; Message for WebSphere MQ (Parameters passed by global array - %mgwmq())
460	N (IP,PORT,REQUEST,%mgwmq)
461	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":WSMQE"
462	;
463	; Close connection to Gateway
464	i REQUEST="CLOSE" d S result=1 G WSMQ1X
465	. i $d(%mgwmq("keepalive","dev")) s DEV=%mgwmq("keepalive","dev") k %mgwmq("keepalive") C DEV
466	. q
467	;
468	D VARS
469	S CRLF=$C(13,10)
470	S REQUEST=$$ucase(REQUEST)
471	I REQUEST="GET" k %mgwsi("send")
472	S res=""
473	S %mgwmq("error")=""
474	s global=+$g(%mgwmq("global"))
475	;
476	; Create TCP connection to Gateway
477	s OK=1
478	i $d(%mgwmq("keepalive","dev")) s DEV=%mgwmq("keepalive","dev")
479	i '$d(%mgwmq("keepalive","dev")) d
480	. S DEV="client$"_$j,timeout=10
481	. O DEV:(connect=IP_":"_PORT_":TCP":attach="client"):timeout:"SOCKET" E S %mgwmq("error")="Cannot connect to MGWSI" s OK=0
482	. q
483	i 'OK S result=0 G WSMQ1X
484	;
485	S maxlen=$$getslen()
486	S BUFFER="",BSIZE=0,EOF=0
487	S DEV(0)=$IO
488	U DEV
489	S REQ="WSMQ "_REQUEST_" v1.1"_CRLF D WSMQS
490	S X="" F S X=$O(%mgwmq(X)) Q:X="" I X'="recv",X'="send" S Y=$G(%mgwmq(X)) I Y'="" S REQ=X_": "_Y_CRLF D WSMQS
491	S REQ=CRLF D WSMQS
492	i global d
493	. S REQ=$G(^MGWSI($j,1,"send")) I REQ'="" D WSMQS
494	. S X="" F S X=$O(^MGWSI($j,1,"send",extra,X)) Q:X="" S REQ=$G(^MGWSI($j,1,"send",extra,X)) I REQ'="" D WSMQS
495	. S X="" F S X=$O(^MGWSI($j,1,"send",X)) Q:X="" I X'=extra S REQ=$G(^MGWSI($j,1,"send",X)) I REQ'="" D WSMQS
496	. q
497	i 'global d
498	. S REQ=$G(%mgwmq("send")) I REQ'="" D WSMQS
499	. S X="" F S X=$O(%mgwmq("send",extra,X)) Q:X="" S REQ=$G(%mgwmq("send",extra,X)) I REQ'="" D WSMQS
500	. S X="" F S X=$O(%mgwmq("send",X)) Q:X="" I X'=extra S REQ=$G(%mgwmq("send",X)) I REQ'="" D WSMQS
501	. q
502	;S REQ=$C(deod),EOF=1 D WSMQS
503	S REQ=$C(7),EOF=1 D WSMQS
504	U DEV
505	s size=+$$rdxx(10)
506	S res="",len=0,sn=0,got=0,pre="",plen=0,hdr=1 F d q:got=size
507	. s get=size-got i get>maxlen s get=maxlen
508	. s x=$$rdxx(get) s got=got+get
509	. i got=size,$e(x,get)=$c(deod) s x=$e(x,1,get-1)
510	. i hdr d q
511	. . s lx=$l(x,$c(13)) f i=1:1:lx d q:'hdr
512	. . . s r=$p(x,$c(13),i)
513	. . . i i=lx s pre=r,plen=$l(pre) q
514	. . . i plen s r=pre_r,pre="",plen=0
515	. . . i r=$c(10) s hdr=0 s pre=$p(x,$c(13),i+1,99999) s:$e(pre)=$c(10) pre=$e(pre,2,99999) s plen=$l(pre) q
516	. . . s nam=$p(r,": ",1),val=$p(r,": ",2,99999)
517	. . . i $e(nam)=$c(10) s nam=$e(nam,2,99999)
518	. . . i nam'="" s %mgwmq(nam)=val
519	. . . q
520	. . q
521	. s to=maxlen-plen
522	. s res=pre_$e(x,1,to),pre=$e(x,to+1,99999),plen=$l(pre)
523	. i global d
524	. . i 'sn s ^MGWSI($j,1,"recv")=res,res="",sn=sn+1 q
525	. . i sn s ^MGWSI($j,1,"recv",extra,sn)=res,res="",sn=sn+1 q
526	. . q
527	. i 'global d
528	. . i 'sn s %mgwmq("recv")=res,res="",sn=sn+1 q
529	. . i sn s %mgwmq("recv",extra,sn)=res,res="",sn=sn+1 q
530	. . q
531	. q
532	s result=1
533	i global d
534	. i plen,'sn s ^MGWSI($j,1,"recv")=pre,plen=0,sn=sn+1
535	. i plen,sn s ^MGWSI($j,1,"recv",extra,sn)=pre,plen=0,sn=sn+1
536	. i $g(^MGWSI($j,1,"r_code"))=2033 s result=0
537	. i $l($g(^MGWSI($j,1,"error"))) s result=0
538	. i $g(^MGWSI($j,1,"recv"))[":MGWSI:ERROR:" s result=0
539	. q
540	i 'global d
541	. i plen,'sn s %mgwmq("recv")=pre,plen=0,sn=sn+1
542	. i plen,sn s %mgwmq("recv",extra,sn)=pre,plen=0,sn=sn+1
543	. i $g(%mgwmq("r_code"))=2033 s result=0
544	. i $l($g(%mgwmq("error"))) s result=0
545	. i $g(%mgwmq("recv"))[":MGWSI:ERROR:" s result=0
546	. q
547	U DEV(0)
548	i $g(%mgwmq("keepalive"))=1 S %mgwmq("keepalive","dev")=DEV
549	i $g(%mgwmq("keepalive"))'=1 C DEV
550	WSMQ1X ; Exit point
551	I $G(mqinfo) M %mgwmq("info")=%mgwmq("error") S %mgwmq("error")=""
552	Q result
553	;
554	WSMQE ; Error (EOF)
555	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":"
556	i $D(DEV(0)) U DEV(0)
557	i '$D(DEV(0)) U 0
558	i $g(%mgwmq("keepalive"))=1 S %mgwmq("keepalive","dev")=DEV
559	i $g(%mgwmq("keepalive"))'=1 C DEV
560	I $l($G(%mgwmq("error"))) G WSMQEX
561	S %mgwmq("error")=$ZS G WSMQEX
562	WSMQEX ; Exit point
563	I $G(mqinfo) M %mgwmq("info")=%mgwmq("error") S %mgwmq("error")=""
564	Q 0
565	;
566	WSMQS ; Send outgoing header
567	N N,X,LEN
568	WSMQS1 S LEN=$L(REQ)
569	I (BSIZE+LEN)<maxlen S BUFFER=BUFFER_REQ,BSIZE=BSIZE+LEN,REQ="",LEN=0 I 'EOF Q
570	W BUFFER D FLUSH
571	; S N=1 F S X=$E(BUFFER,N,N+255) Q:X="" W X S N=N+255+1 D FLUSH
572	S BUFFER=REQ,BSIZE=LEN
573	I EOF S REQ="" I BSIZE G WSMQS1
574	Q
575	;
576	WSMQSRV(%mgwmq) ; Server to WebSphere MQ
577	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":WSMQSRVE^%ZMGWSIS"
578	i global d
579	. n x
580	. s x="" f s x=$o(^MGWSI($j,1,x)) q:x="" i x'="recv" s %mgwmq(x)=$g(^MGWSI($j,1,x))
581	. q
582	D @$g(%mgwmq("routine"))
583	k %mgwmq("qm_name")
584	k %mgwmq("q_name")
585	k %mgwmq("recv")
586	i global d
587	. k ^MGWSI($j,1,"qm_name")
588	. k ^MGWSI($j,1,"q_name")
589	. k ^MGWSI($j,1,"recv")
590	. m ^MGWSI($j,1)=%mgwmq
591	. q
592	Q 1
593	WSMQSRVE ; Error
594	k %mgwmq("qm_name")
595	k %mgwmq("q_name")
596	k %mgwmq("recv")
597	S %mgwmq("send")="ERROR: "_$ZS
598	S %mgwmq("error")="ERROR: "_$ZS
599	Q 0
600	;
601	WSX(IP,PORT,REQUEST,%mgwmq) ; Message for Web Server (Parameters passed by reference)
602	Q $$WSX1(IP,PORT,REQUEST)
603	;
604	WSX1(IP,PORT,REQUEST) ; Message for Web Server (Parameters passed by global array - %mgwmq())
605	N (IP,PORT,REQUEST,%mgwmq)
606	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":WSXE"
607	D VARS
608	S CRLF=$C(13,10)
609	;
610	; Create TCP connection to server
611	s OK=1
612	S DEV="client$"_$j,timeout=10
613	O DEV:(connect=IP_":"_PORT_":TCP":attach="client"):timeout:"SOCKET" E S %mgwmq("error")="Cannot connect to Web Server" s OK=0
614	i 'OK S result=0 G WSXEX
615	;
616	S maxlen=$$getslen()
617	S DEV(0)=$IO
618	U DEV
619	S REQ=""
620	S REQ=REQ_"POST /mgwsi/sys/system_functions.mgwsi?FUN="_REQUEST_"&KEY="_$$WSXESC($g(%mgwmq("key")))_" HTTP/1.1"_CRLF
621	S REQ=REQ_"Host: "_IP_$s(PORT'=80:":"_PORT,1:"")_CRLF
622	S REQ=REQ_"Content-Type: text/plain"_CRLF
623	S REQ=REQ_"User-Agent: zmgwsi v"_$g(version)_CRLF
624	S REQ=REQ_"Content-Length: "_$L($G(%mgwmq("send")))_CRLF
625	S REQ=REQ_"Connection: close"_CRLF
626	S REQ=REQ_CRLF
627	S REQ=REQ_$G(%mgwmq("send"))
628	;
629	W REQ D FLUSH
630	;
631	s res=$$rdxx(60) f q:res[$c(13,10,13,10) s res=res_$$rdxx(1)
632	s head=$p(res,$c(13,10,13,10),1),res=$p(res,$c(13,10,13,10),2,9999)
633	s headn=$$lcase(head)
634	s clen=+$p(headn,"content-length: ",2)
635	s rlen=clen-$l(res)
636	s res=res_$$rdxx(rlen)
637	WSXE ; Error (EOF)
638	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":"
639	i $D(DEV(0)) U DEV(0)
640	i '$D(DEV(0)) U 0
641	C DEV
642	WSXEX ; Exit point
643	s %mgwmq("recv")=$g(res)
644	Q 0
645	;
646	WSXESC(IN)
647	N OUT,I,A,C,LEN,N16
648	S OUT="",N16=0 F I=1:1:$L(IN) D
649	. S C=$E(IN,I),A=$A(C)
650	. I A=32 S C="+" S OUT=OUT_C Q
651	. I A<32!(A>127)!(C?1P) S LEN=$$esize(.N16,A,16) S:LEN=1 N16="0"_N16 S C="%"_N16 S OUT=OUT_C Q
652	. S OUT=OUT_C Q
653	. Q
654	Q OUT
655	;
656	MPHP ; Request from m_client
657	n port,dev,conc,cmnd,nato
658	s cmnd=$p(req,"^",4)
659	d PHP
660	q
661	;
662	PHP ; Serve request from m_client
663	n argz,i,m
664	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":phpe^%ZMGWSIS"
665	s res=""
666	i cmnd="S" d set
667	i cmnd="G" d get
668	i cmnd="K" d kill
669	i cmnd="D" d data
670	i cmnd="O" d order
671	i cmnd="P" d previous
672	i cmnd="M" d mergedb
673	i cmnd="m" d mergephp
674	i cmnd="H" d html
675	i cmnd="y" d htmlm
676	i cmnd="h" d http
677	i cmnd="X" d proc
678	i cmnd="x" d meth
679	i cmnd="W" d web
680	q
681	phpe ; Error
682	d EVENT($$client()_" Error : "_$ZS)
683	k res s res="",res(2)="M Server Error : ["_$g(req(2))_"]"_$tr($ZS,"<>%","[]^")_$g(ref)
684	s res(1)="00000ce"_$C(10)
685	q
686	;
687	client() ; Get client name
688	s name="m_client"
689	i $g(%ZCS("client"))="z" s name="m_php"
690	i $g(%ZCS("client"))="j" s name="m_jsp"
691	i $g(%ZCS("client"))="a" s name="m_aspx"
692	i $g(%ZCS("client"))="p" s name="m_python"
693	i $g(%ZCS("client"))="r" s name="m_ruby"
694	i $g(%ZCS("client"))="h" s name="m_apache"
695	i $g(%ZCS("client"))="c" s name="m_cgi"
696	i $g(%ZCS("client"))="w" s name="m_websphere_mq"
697	q name
698	;
699	set ; Global set
700	i argc<3 q
701	s argz=argc-1
702	s fun=0 d ref
703	x "s "_ref_"="_"req"_argc
704	d res
705	Q
706	;
707	get ; Global get
708	i argc<2 q
709	s argz=argc
710	s fun=0 d ref
711	x "s res=$g("_ref_")"
712	d res
713	Q
714	;
715	kill ; Global kill
716	i argc<1 q
717	s argz=argc
718	s fun=0 d ref
719	x "k "_ref
720	d res
721	Q
722	;
723	data ; Global get
724	i argc<2 q
725	s argz=argc
726	s fun=0 d ref
727	x "s res=$d("_ref_")"
728	d res
729	Q
730	;
731	order ; Global order
732	i argc<3 q
733	s argz=argc
734	s fun=0 d ref
735	x "s res=$o("_ref_")"
736	d res
737	Q
738	;
739	previous ; Global reverse order
740	i argc<3 q
741	s argz=argc
742	s fun=0 d ref
743	x "s res=$o("_ref_",-1)"
744	d res
745	Q
746	;
747	mergedb ; Global Merge from PHP
748	i argc<3 q
749	s a="" f argz=1:1 q:'$d(req(argz)) i $g(req(argz,0))=1 s a=req(argz) q
750	i a="" q
751	s argz=argz-1
752	s fun=0 d ref
753	i ref["()" s ref=$p(ref,"()",1)
754	i $g(@req(argz+2))["ks" x "k "_ref
755	x "m "_ref_"="_a
756	d res
757	Q
758	;
759	mergephp ; Global Merge to PHP
760	i argc<3 q
761	s a="" f argz=1:1 q:'$d(req(argz)) i $g(req(argz,0))=1 s a=req(argz) q
762	i a="" q
763	s argz=argz-1
764	s fun=0 d ref
765	i ref["()" s ref=$p(ref,"()",1)
766	x "m "_a_"="_ref
767	s argz=argz+1
768	s abyref=1
769	d res
770	Q
771	;
772	html ; HTML
773	s res(1)=$c(1,2,1,10)_"0sc"_$C(10) w res(1)
774	i argc<2 q
775	s argz=argc
776	s fun=0 d ref
777	x "n ("_refn_") d "_ref
778	Q
779	;
780	htmlm ; HTML (COS) Method
781	s res(1)=$c(1,2,1,10)_"0sc"_$C(10) w res(1)
782	i argc<1 q
783	s argz=argc
784	s fun=0 d oref
785	s ref=$tr($p(ref,",",1,2),".","")_","_$p(ref,",",3,999)
786	i argc=1 x "n ("_refn_") s req(-1)=$zobjclassmethod()"
787	i argc>1 x "n ("_refn_") s req(-1)=$zobjclassmethod("_ref_")"
788	s res=$g(req(-1))
789	Q
790	;
791	web ; Web request
792	N REQ,x,y,i
793	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":webe^%ZMGWSIS"
794	s res(1)=$c(1,2,1,10)_"0sc"_$C(10) w res(1)
795	i argc'=4 g webe
796	s argz=argc
797	s fun=1 d ref
798	s x="" f s x=$o(req4(x)) q:x="" s y="" f i=1:1 s y=$o(req4(x,y)) q:y="" i y'=i m req4(x,i)=req4(x,y) k req4(x,y)
799	x "n ("_refn_") d "_ref
800	q
801	webe ; error
802	S REQ=""
803	S REQ=REQ_"HTTP/1.1 200 OK"_$C(13,10)
804	S REQ=REQ_"Content-type: text/plain"_$C(13,10)
805	S REQ=REQ_"Connection: close"_$C(13,10)
806	S REQ=REQ_$C(13,10)
807	S REQ=REQ_"Error calling web function "_$g(ref)_$g(refn)_$C(13,10)
808	S REQ=REQ_$ZS
809	S REQ=REQ_"Web functions contain two arguments"_$C(13,10)
810	W REQ
811	Q
812	;
813	WEB(CGI,DATA)
814	N REQ,X,Y
815	S REQ=""
816	S REQ=REQ_"HTTP/1.1 200 OK"_$C(13,10)
817	S REQ=REQ_"Content-type: text/plain"_$C(13,10)
818	S REQ=REQ_"Connection: close"_$C(13,10)
819	S REQ=REQ_$C(13,10)
820	W REQ
821	W $G(CGI)
822	S X="" F S X=$O(CGI(X)) Q:X="" W X_"="_$G(CGI(X))_$C(13,10)
823	W $C(13,10)
824	S X="" F S X=$O(DATA(X)) Q:X="" S Y="" F S Y=$O(DATA(X,Y)) Q:Y="" W X_":"_Y_"="_$G(DATA(X,Y))_$C(13,10)
825	Q
826	;
827	http ; HTTP
828	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":httpe"
829	i argc<2 q
830	s x=$$http1(.req2,@req(3))
831	httpx ; exit
832	k ^%MGW("MPC",$J,"CONTENT")
833	Q
834	httpe ; Error
835	w "<html><head><title>m_php/jsp: Error</title></head><h2>eXtc is not installed on this computer<h2></html>"
836	q
837	;
838	http1(%CGIEVAR,content) ; HTTP
839	n (%CGIEVAR,content)
840	s test=0
841	i test d q 0
842	. w "<br><b>CGI</b>"
843	. s x="" f s x=$o(%CGIEVAR(x)) q:x="" w "<br>"_x_"="_$g(%CGIEVAR(x))
844	. w "<br><b>CONTENT</b>"
845	. s x="" f s x=$o(^%MGW("MPC",$J,"CONTENT",x)) q:x="" w "<br>"_x_"="_$g(^%MGW("MPC",$J,"CONTENT",x))
846	. q
847	i $G(%CGIEVAR("key_eXtcServer"))="true" d QUIT 1
848	. ; break out to eXtc Server here
849	. s namespace=$G(%CGIEVAR("key_namespace"))
850	. s:namespace'="" namespace=$G(^%eXtc("system","phpSettings","namespace",namespace))
851	. s:namespace="" namespace=$G(^%eXtc("system","phpSettings","defaultNamespace"))
852	. s:namespace="" namespace="%CACHELIB"
853	. d PHPServer^%eXMLServer
854	QUIT 0
855	;
856	proc ; M extrinsic function
857	i argc<2 q
858	s argz=argc
859	s fun=1 d ref
860	i argc=2 x "n ("_refn_") s req(-1)=$$"_ref_"()"
861	i argc>2 x "n ("_refn_") s req(-1)=$$"_ref
862	s res=$g(req(-1))
863	d res
864	Q
865	;
866	meth ; M (COS) method
867	;
868	; Synopsis:
869	; s err=$zobjclassmethod(className,methodName,param1,...,paramN)
870	;
871	; s className="eXtc.DOMAPI"
872	; s methodName="openDOM"
873	; s err=$zobjclassmethod(className,methodName)
874	;
875	; ; This is equivalent to ...
876	; s err=##class(eXtc.DOMAPI).openDOM()
877	;
878	; s methodName="getDocumentNode"
879	; s documentName="eXtcDOM2"
880	; s err=$zobjclassmethod(className,methodName,documentName)
881	; ; This is equivalent to ...
882	; s err=##class(eXtc.DOMAPI).getDocumentNode("eXtcDOM2")
883	;
884	i argc<1 q
885	s argz=argc
886	s fun=1 d oref
887	s ref=$tr($p(ref,",",1,2),".","")_","_$p(ref,",",3,999)
888	i argc=1 x "n ("_refn_") s req(-1)=$zobjclassmethod()"
889	i argc>1 x "n ("_refn_") s req(-1)=$zobjclassmethod("_ref_")"
890	s res=$g(req(-1))
891	d res
892	Q
893	;
894	sort(a) ; Sort an array
895	q 1
896	;
897	ref ; Global reference
898	n com,i,strt,a1
899	s array=0,refn="res,req,extra,global,oversize"
900	i argc<2 q
901	s a1=$g(@req(2))
902	s strt=2 i a1?1"^"."^" s strt=strt+1
903	s ref=@req(strt) i argc=strt q
904	s ref=ref_"("
905	s com="" f i=strt+1:1:argz s refn=refn_","_req(i),ref=ref_com_$s(fun:".",1:"")_req(i),com=","
906	s ref=ref_")"
907	q
908	;
909	oref ; Object reference
910	n com,i,strt,a1
911	s array=0,refn="req,extra,global,oversize"
912	i argc<2 q
913	s a1=$g(@req(2))
914	s strt=2 i a1?1"^"."^" s strt=strt+1
915	i '$d(req(strt)) q
916	s ref=""
917	s com="" f i=strt:1:argz s refn=refn_","_req(i),ref=ref_com_$s(fun:".",1:"")_req(i),com=","
918	q
919	;
920	res ; Return result
921	n i,a,sn,argc
922	s maxlen=$$getslen()
923	d VARS
924	s anybyref=0 f argc=1:1:argz q:'$d(req(argc)) i $g(req(argc,1)) s anybyref=1 q
925	i 'anybyref d q
926	. d send($g(res))
927	. i oversize f sn=1:1 q:'$d(^MGWSI($j,0,extra,sn)) d send($g(^(sn)))
928	. q
929	s res(1)="00000cc"_$C(10)
930	s size=$l($g(res)),byref=0
931	i oversize f sn=1:1 q:'$d(^MGWSI($j,0,extra,sn)) s size=size+$l(^(sn))
932	s x=$$ehead(.head,size,byref,ddata)
933	d send(head)
934	d send($g(res))
935	i oversize f sn=1:1 q:'$d(^MGWSI($j,0,extra,sn)) d send($g(^(sn)))
936	f argc=1:1:argz q:'$d(req(argc)) d
937	. s byref=$g(req(argc,1))
938	. s array=$g(req(argc,0))
939	. i 'byref s size=0,x=$$ehead(.head,size,byref,ddata) d send(head) q
940	. i 'array d q
941	. . s size=$l($g(@req(argc)))
942	. . f sn=1:1 q:'$d(@(req(argc)_"(extra,sn)")) s size=size+$l($g(@(req(argc)_"(extra,sn)")))
943	. . s x=$$ehead(.head,size,byref,ddata)
944	. . d send(head)
945	. . d send($g(@req(argc)))
946	. . f sn=1:1 q:'$d(@(req(argc)_"(extra,sn)")) d send($g(@(req(argc)_"(extra,sn)")))
947	. . q
948	. s x=$$ehead(.head,0,0,darec)
949	. d send(head)
950	. d resa
951	. s x=$$ehead(.head,0,0,deod)
952	. d send(head)
953	. q
954	q
955	;
956	res1 ; Link to array parser
957	d send($g(req(argc,0))_$g(req(argc,1)))
958	i '$g(req(argc,1)) q
959	i $g(req(argc,0))=0 d send($g(@req(argc))) q
960	s a=req(argc),fkey="" i global s a="^MGWSI",fkey="$j,argc-2"
961	d resa
962	q
963	;
964	resa ; Return array
965	n ref,kn,ok,def,data,txt
966	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":resae"
967	s byref=0
968	s a=req(argc),fkey="" i global s a="^MGWSI",fkey="$j,argc-2"
969	i a="" q
970	i global d
971	. i ($d(@(a_"("_fkey_")"))#10) d
972	. . s txt=" ",x=$$ehead(.head,$l(txt),byref,dakey) d send(head),send(txt)
973	. . s size=0
974	. . s size=size+$l($g(@req(argc)))
975	. . f sn=1:1 q:'$d(@(a_"("_fkey_","_"extra,sn)")) s size=size+$l($g(^(sn)))
976	. . s x=$$ehead(.head,size,byref,ddata) d send(head)
977	. . d send($g(@req(argc)))
978	. . f sn=1:1 q:'$d(@(a_"("_fkey_","_"extra,sn)")) d send($g(^(sn)))
979	. . q
980	. s fkey=fkey_","
981	. q
982	i 'global d
983	. i ($d(@a)#10),$l($g(@a)) d
984	. . s txt=" ",x=$$ehead(.head,$l(txt),byref,dakey) d send(head),send(txt)
985	. . s size=0
986	. . s size=size+$l($g(@a))
987	. . f sn=1:1 q:'$d(@(a_"(extra,sn)")) s size=size+$l($g(@(a_"(extra,sn)")))
988	. . s x=$$ehead(.head,size,byref,ddata) d send(head)
989	. . d send($g(@a))
990	. . f sn=1:1 q:'$d(@(a_"(extra,sn)")) d send($g(@(a_"(extra,sn)")))
991	. . q
992	. q
993	s ok=0,kn=1,x(kn)="",ref="x("_kn_")"
994	f s x(kn)=$o(@(a_"("_fkey_ref_")")) d resa1 i ok q
995	q
996	resae ; Error
997	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":"
998	q
999	;
1000	resa1 ; Array node
1001	i x(kn)=extra q
1002	i x(kn)="",kn=1 s ok=1 q
1003	i x(kn)="" s kn=kn-1,ref=$p(ref,",",1,$l(ref,",")-1) q
1004	s def=$d(@(a_"("_fkey_ref_")")) i (def\10) d resa3
1005	s data=$g(@(a_"("_fkey_ref_")"))
1006	i (def#10) d resa2
1007	i (def\10) s kn=kn+1,x(kn)="",ref=ref_","_"x("_kn_")"
1008	q
1009	;
1010	resa2 ; Array node data
1011	n i,spc
1012	f i=1:1:kn s x=$$ehead(.head,$l(x(i)),byref,dakey) d send(head),send(x(i))
1013	i $g(%ZCS("client"))="z",(def\10) s spc=" ",x=$$ehead(.head,$l(spc),byref,dakey) d send(head),send(spc)
1014	s size=$l(data)
1015	f sn=1:1 q:'$d(@(a_"("_fkey_ref_",extra,sn)")) s size=size+$l($g(@(a_"("_fkey_ref_",extra,sn)")))
1016	s x=$$ehead(.head,size,byref,ddata) d send(head)
1017	d send(data)
1018	f sn=1:1 q:'$d(@(a_"("_fkey_ref_",extra,sn)")) d send($g(@(a_"("_fkey_ref_",extra,sn)")))
1019	q
1020	;
1021	resa3 ; Array node data with descendants - test for non-extra data
1022	n y
1023	s y="" f s y=$o(@(a_"("_ref_",y)")) q:y="" i y'=extra q
1024	i y="" s def=1
1025	q
1026	;
1027	send(data) ; Send data
1028	n n
1029	;D EVENT(data_$g(res(1)))
1030	s n=$o(res(""),-1)
1031	i n="" s n=1
1032	i $l($g(res(n)))+$l(data)>maxlen s n=n+1
1033	s res(n)=$g(res(n))_data
1034	q
1035	;
1036	getsys() ; Get system type
1037	s systype="GTM"
1038	q systype
1039	;
1040	getuci() ; Get NameSpace/UCI
1041	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":getucie^%ZMGWSIS"
1042	s %UCI=$ZG
1043	q %UCI
1044	getucie ; Error
1045	q ""
1046	;
1047	getslen() ; Get maximum string length
1048	s slen=32000
1049	q slen
1050	;
1051	lcase(string) ; Convert to lower case
1052	q $tr(string,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
1053	;
1054	ucase(string) ; Convert to upper case
1055	q $tr(string,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
1056	;
1057	setio(tblname) ; Set I/O translation
1058	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":setioe^%ZMGWSIS"
1059	Q ""
1060	setioe ; Error - do nothing
1061	Q ""
1062	;
1063	zcvt(buffer,tblname) ; Translate buffer
1064	new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":zcvte^%ZMGWSIS"
1065	Q buffer
1066	zcvte ; Error - do nothing
1067	Q buffer
1068	;
1069	WSMQTEST ; Test link to WebSphere MQ
1070	n %mgwmq,response
1071	w !,"Sending Test Message to MGWSI/WebSphere MQ interface..."
1072	S response=$$WSMQ("127.0.0.1",7040,"TEST",.%mgwmq)
1073	W !,"Response: ",response," ",$G(%mgwmq("recv"))
1074	Q
1075	;
1076	WSMQTSTX(IP,PORT) ; Test link to WebSphere MQ: IP address and Port specified
1077	n %mgwmq,response
1078	w !,"Sending Test Message to MGWSI/WebSphere MQ interface..."
1079	S response=$$WSMQ(IP,PORT,"TEST",.%mgwmq)
1080	W !,"Response: ",response," ",$G(%mgwmq("recv"))
1081	Q
1082	;
1083	HTEST ; Return HTML
1084	n systype
1085	s systype=$$getsys()
1086	w "<I>A line of HTML from "_systype_"</I>"
1087	Q
1088	;
1089	HTEST1(P1) ; Return HTML
1090	n x,systype
1091	s systype=$$getsys()
1092	;W "HTTP/1.1 200 OK",$c(13,10)
1093	;W "Content-Type: text/html",$c(13,10)
1094	;W "Connection: close",$c(13,10)
1095	;W $c(13,10)
1096	w "<I>HTML content returned from "_systype_"</I>"
1097	W "<br><I>The input parameter passed was: <B>"_$g(P1)_"</B></I>"
1098	s x="" f s x=$o(P1(x)) q:x="" W "<br><I>Array element passed: <B>"_x_" = "_$g(P1(x))_"</B></I>"
1099	Q
1100	;
1101	PTEST() ; Return result
1102	n systype
1103	s systype=$$getsys()
1104	q "Result from "_systype_" process: "_$J_"; UCI: "_$$getuci()
1105	Q
1106	;
1107	PTEST1(P1) ; Return result
1108	n systype
1109	s systype=$$getsys()
1110	q "Result from "_systype_" process: "_$J_"; UCI: "_$$getuci()_"; The input parameter passed was: "_P1
1111	;
1112	PTEST2(P1,P2) ; Manipulate an array
1113	n n,x,systype
1114	s systype=$$getsys()
1115	s n=0,x="" f s x=$o(P1(x)) q:x="" s n=n+1
1116	s P1("Key from M - 1")="Value 1"
1117	s P1("Key from M - 2")="Value 2"
1118	s P2="Stratford"
1119	q "Result from "_systype_" process: "_$J_"; UCI: "_$$getuci()_"; "_n_" elements were received in an array, 2 were added by this procedure"
1120	;

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZMGWSIS.m@ 1800

Download in other formats: