source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSBSE2.m@ 1093

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

initial load of FOIAVistA 6/30/08 version
File size: 3.1 KB
Line 
1XUSBSE2 ;FO-OAK/JLI-CONNECT WITH HTTP SERVER AND GET REPLY ;5/24/07 13:47
2 ;;8.0;KERNEL;**404,439**;Jul 10, 1995;Build 12
3 Q
4 ;
5POST(SERVER,PORT,PAGE,DATA) ;
6 Q $$ENTRY(SERVER,$G(PORT),$G(PAGE),"POST",$G(DATA))
7 ;
8GET(SERVER,PORT,PAGE) ;
9 Q $$ENTRY(SERVER,$G(PORT),$G(PAGE),"GET")
10 ;
11ENTRY(SERVER,PORT,PAGE,HTTPTYPE,DATA) ;
12 N DONE,XVALUE,XWBICNT,XWBRBUF,XWBSBUF,XWBTDEV,XWBDEBUG,XWBOS,XWBT,XWBTIME,POP
13 N $ESTACK,$ETRAP S $ETRAP="D TRAP^XUSBSE2"
14 S PAGE=$G(PAGE,"/") I PAGE="" S PAGE="/"
15 S HTTPTYPE=$G(HTTPTYPE,"GET")
16 S DATA=$G(DATA),PORT=$G(PORT,80)
17 D SAVDEV^%ZISUTL("XUSBSE") ;S IO(0)=$P
18 D INIT^XWBTCPM
19 D OPEN^XWBTCPM2(SERVER,PORT)
20 I POP Q "DIDN'T OPEN CONNECTION"
21 S XWBSBUF=""
22 U XWBTDEV
23 D WRITE^XWBRW(HTTPTYPE_" "_PAGE_" HTTP/1.0"_$C(13,10))
24 I HTTPTYPE="POST" D
25 . D WRITE^XWBRW("Referer: http://"_$$KSP^XUPARAM("WHERE")_$C(13,10))
26 . D WRITE^XWBRW("Content-Type: application/x-www-form-urlencoded"_$C(13,10))
27 . D WRITE^XWBRW("Cache-Control: no-cache"_$C(13,10))
28 . D WRITE^XWBRW("Content-Length: "_$L(DATA)_$C(13,10,13,10))
29 . D WRITE^XWBRW(DATA)
30 D WRITE^XWBRW($C(13,10))
31 D WBF^XWBRW
32 S XWBRBUF="",DONE=0,XWBICNT=0
33 S XVALUE=$$DREAD($C(13,10)) I XVALUE'[200 S XVALUE=$P(XVALUE," ",2,3)
34 I '$T S XVALUE=$$DREAD($C(13,10,13,10)),XVALUE=$$DREAD($C(13,10))
35 D CLOSE ;I IO="|TCP|80" U IO D ^%ZISC
36 Q $P(XVALUE,$C(13,10))
37 ;
38CLOSE ;
39 D CLOSE^%ZISTCP,GETDEV^%ZISUTL("XUSBSE") I $L(IO) U IO
40 Q
41 ;
42DREAD(D,TO) ;Delimiter Read
43 N R,S,DONE,C,L
44 N $ES,$ET S $ET="S DONE=1,$EC="""" Q"
45 S R="",DONE=0,D=$G(D,$C(13)),C=0
46 S TO=$S($G(TO)>0:TO,$G(XWBTIME(1))>0:XWBTIME(1),1:60)/2+1
47 U XWBTDEV
48 F D Q:DONE
49 . S L=$F(XWBRBUF,D),L=$S(L>0:L,1:$L(XWBRBUF)+1),R=R_$E(XWBRBUF,1,L-1),XWBRBUF=$E(XWBRBUF,L,32000)
50 . I (R[D)!(C>TO) S DONE=1 Q
51 . R XWBRBUF:2 S:'$T C=C+1 S:$L(XWBRBUF) C=0
52 . I $G(XWBDEBUG)>2,$L(XWBRBUF) D LOG^XWBDLOG($E("rd ("_$L(XWBRBUF)_"): "_XWBRBUF,1,255))
53 . Q
54 Q R
55 ;
56TRAP ;
57 I '(($EC["READ")!($EC["WRITE")) D ^%ZTER
58 D CLOSE,LOG^XWBDLOG("Error: "_$$EC^%ZOSV):$G(XWBDEBUG),UNWIND^%ZTER
59 Q
60 ;
61 ;Test code below here
62 ; MODIFY THE PROGRAM TO CHANGE THE 10.161.12.182 TO
63 ; IP ADDRESSES FOR THE WORKSTATION WITH THE BSE SAMPLE
64 ; SERVER
65EN(ADDRESS) ; test with input address or 10.161.12.182 if none entered
66 N VALUE,PAGE,SERVER,PORT
67 S ADDRESS=$G(ADDRESS,"10.237.131.26")
68 S PAGE="/",SERVER=ADDRESS,PORT=80
69 I SERVER["/" D
70 . I SERVER["//" S SERVER=$P(SERVER,"//",2)
71 . I SERVER["/" S PAGE="/"_$P(SERVER,"/",2,99),SERVER=$P(SERVER,"/")
72 . I SERVER[":" S PORT=$P(SERVER,":",2),SERVER=$P(SERVER,":")
73 . Q
74 S VALUE=$$ENTRY(SERVER,PORT,PAGE) ; $G(ADDRESS,"10.237.131.26"))
75 D HOME^%ZIS ;I IO="|TCP|80" U IO D ^%ZISC
76 W !,VALUE
77 Q
78 ;
79EN1 ;
80 D EN("10.237.131.26/page1.htm")
81 Q
82 ;
83EN2 ;
84 D EN("10.237.131.26/level2/page2.htm")
85 Q
86 ;
87 ;
88TESTPOST ;
89 W !,$$POST("10.237.131.26","/","xVAL=XWBHDL851-487411_0")
90 I IO="|TCP|80" U IO D ^%ZISC
91 Q
92 ;
93 ;Sample of what IIS returns
94 ;HTTP/1.1 200 OK
95 ;Server: Microsoft-IIS/5.1
96 ;Date: Mon, 12 Feb 2007 22:57:55 GMT
97 ;X-Powered-By: ASP.NET
98 ;X-AspNet-Version: 1.1.4322
99 ;Set-Cookie: ASP.NET_SessionId=vsiqfgygjwsaru55bj4aik45; path=/
100 ;Cache-Control: private
101 ;Content-Type: text/html; charset=utf-8
102 ;
103 ;999999999^MONSON,STEVE^CLEVELAND VAMC^541^136672^^
104 ;
Note: See TracBrowser for help on using the repository browser.