ONCX10A ;HCIOFO/SG - HTTP 1.0 CLIENT (TOOLS) ; 8/11/04 8:26am
;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
;
Q
;
;***** APPENDS RECEIVED PIECE OF DATA TO THE DESTINATION BUFFER
;
; BUF Received data
;
; [NEWLINE] Start a new line after appending the data
;
; The ONC8BUF, ONC8DST, ONC8IS, ONC8MBL, ONC8PTR, and ONC8SL
; variables must be properly initialized before calling this
; procedure (see the $$RECEIVE^ONCX10A for details).
;
APPEND(BUF,NEWLINE) ;
N BASE,L
S L=$L(BUF) S:$A(BUF,L)=13 L=L-1
;--- Append the data
I L'<ONC8SL D
. S ONC8BUF=ONC8BUF_$E(BUF,1,ONC8SL),L=L-ONC8SL
. S BASE=1
. F D Q:L'>0
. . I 'ONC8IS S @ONC8DST@(ONC8PTR)=ONC8BUF
. . E S @ONC8DST@(ONC8PTR,ONC8IS)=ONC8BUF
. . S BASE=BASE+ONC8SL,ONC8IS=ONC8IS+1,ONC8SL=ONC8MBL
. . S ONC8BUF=$E(BUF,BASE,BASE+ONC8SL-1),L=L-ONC8SL
. S ONC8SL=-L
E S ONC8BUF=ONC8BUF_$E(BUF,1,L),ONC8SL=ONC8SL-L
;--- Flush the buffer and start a new line
I $G(NEWLINE) D S ONC8BUF="",ONC8IS=0,ONC8PTR=ONC8PTR+1,ONC8SL=ONC8MBL
. I 'ONC8IS S @ONC8DST@(ONC8PTR)=ONC8BUF Q
. S @ONC8DST@(ONC8PTR,ONC8IS)=ONC8BUF
Q
;
;***** CALCULATES NUMBER OF BYTES IN THE MESSAGE BODY
;
; ONC8DATA Closed root of a variable containing body
; of the message
;
; NLS Length of the line terminator(s)
;
DATASIZE(ONC8DATA,NLS) ;
N SIZE
S SIZE=0
F S I=$O(@ONC8DATA@(I)) Q:I="" D S SIZE=SIZE+NLS
. S SIZE=SIZE+$L($G(@ONC8DATA@(I)))
. S J=""
. F S J=$O(@ONC8DATA@(I,J)) Q:J="" D
. . S SIZE=SIZE+$L($G(@ONC8DATA@(I,J)))
Q $S(SIZE>0:SIZE-NLS,1:0)
;
;***** PROCESSES THE HTTP HEADER
;
; .ONC8H Reference to a local array containing
; the raw header data
;
; .ONC8HDR Reference to a local variable where the parsed
; header will be returned
;
; Return values:
; <0 Error Descriptor
; >0 HTTP Status Code^Description
;
N BUF,I,NAME,TAB,TMP
S ONC8HDR=$$NORMSTAT($G(ONC8H(1))),TAB=$C(9)
F I=2:1 S BUF=$TR($G(ONC8H(I)),TAB," ") Q:BUF="" D
. ;--- Continuation of the previous header line
. I $E(BUF,1)=" " D:$G(NAME)'="" Q
. . S TMP=$$TRIM^XLFSTR(BUF)
. . S:TMP'="" ONC8HDR(NAME)=ONC8HDR(NAME)_" "_TMP
. ;--- New header line
. S NAME=$$UP^XLFSTR($$TRIM^XLFSTR($P(BUF,":")))
. S:NAME'="" ONC8HDR(NAME)=$$TRIM^XLFSTR($P(BUF,":",2,999))
Q $P(ONC8HDR," ",2)_U_$P(ONC8HDR," ",3,999)
;
;***** NORMALIZES THE HTTP STATUS LINE
NORMSTAT(STATUS) ;
N I,J1,J2,TMP
;--- Remove leading and trailing spaces
S STATUS=$$TRIM^XLFSTR(STATUS)
;--- Replace groups of consecutive spaces with single spaces
S J2=1
F I=1,2 D Q:'J1
. S J1=$F(STATUS," ",J2) Q:'J1
. F J2=J1:1 Q:$E(STATUS,J2)'=" "
. S $E(STATUS,J1,J2-1)=""
;--- Return normalized status line
Q STATUS
;
;***** RECEIVES AN HTTP RESPONSE
;
; TIMEOUT Timeout value (in seconds) for TCPIP input.
;
; [ONC8DATA] Closed root of the variable where the message
; body is returned. See the $$GETURL^ONCX10
; for details.
;
; [.ONC8HDR] Reference to a local variable where the parsed
; headers will be returned. See the $$GETURL^ONCX10
; for details.
;
RECEIVE(TIMEOUT,ONC8DATA,ONC8HDR) ;
; ONC8BUF Work buffer where the current line is being built
; ONC8DST Closed root of the current destination buffer used
; by the APPEND^ONCX10A
; ONC8H Temporary buffer for the raw HTTP header
; ONC8IS Subscript of the current continuation sub-node in
; the destination buffer (if 0 then the current main
; node is used)
; ONC8MBL Maximum buffer length
; ONC8PTR Subscript of the current node in the dest. buffer
; ONC8SL Number of available bytes in the current (sub)node
;
N $ESTACK,$ETRAP,BLCHS,BUF,EXIT,I1,I2,MBL,ONC8BUF,ONC8DST,ONC8H,ONC8IS,ONC8MBL,ONC8PTR,ONC8SL,RTO,STATUS,TMP,X
S BLCHS=$C(9,10,12,13)_" ",ONC8MBL=245
K:$G(ONC8DATA)'="" @ONC8DATA K ONC8HDR
S ONC8BUF="",ONC8IS=0,ONC8PTR=1,ONC8SL=ONC8MBL
;--- Setup the error processing
S X="RCVERR^ONCX10A",@^%ZOSF("TRAP"),$ETRAP=""
;--- Receive the header (until the first empty line)
U IO
S ONC8DST="ONC8H",(EXIT,RTO)=0
F R BUF#ONC8MBL:TIMEOUT S RTO='$T D Q:EXIT!RTO
. S I1=1
. F S I2=$F(BUF,$C(10),I1) Q:'I2 D Q:EXIT
. . S TMP=$E(BUF,I1,I2-2) D APPEND(TMP,1) S I1=I2
. . S:$TR(TMP,BLCHS)="" EXIT=1
. D:'EXIT APPEND($E(BUF,I1,ONC8MBL))
;--- A header must end with an empty line.
;--- Otherwise, there was a timeout.
Q:'EXIT $$ERROR^ONCXERR(-7)
;--- Remove ending of the header from the buffer. The buffer
;--- can contain beginning of the message body.
S:I1>1 $E(BUF,1,I1-1)=""
;--- Process the header
S STATUS=$$HEADER(.ONC8H,.ONC8HDR)
;--- Receive the message body
D:$G(ONC8DATA)'=""
. N CNTLEN,RDLEN
. S RDLEN=ONC8MBL
. ;--- Check for Content-Length header
. I $D(ONC8HDR("CONTENT-LENGTH")) D Q:CNTLEN'>0
. . S CNTLEN=+ONC8HDR("CONTENT-LENGTH")
. . S:CNTLEN<ONC8MBL RDLEN=CNTLEN
. E S CNTLEN=-1
. ;--- Read the content
. S ONC8DST=ONC8DATA,RTO=0
. F D Q:'CNTLEN!RTO R BUF#RDLEN:TIMEOUT S RTO='$T
. . D:CNTLEN>0
. . . S CNTLEN=CNTLEN-$L(BUF) S:CNTLEN<0 CNTLEN=0
. . . S:CNTLEN<RDLEN RDLEN=CNTLEN
. . S I1=1
. . F S I2=$F(BUF,$C(10),I1) Q:'I2 D
. . . D APPEND($E(BUF,I1,I2-2),1) S I1=I2
. . D APPEND($E(BUF,I1,ONC8MBL))
;--- Flush the buffers and process the header (only if necessary)
RCVERR U $P
D APPEND("",1)
S:$G(STATUS)="" STATUS=$$HEADER(.ONC8H,.ONC8HDR)
Q STATUS
;
;***** SENDS THE HTTP REQUEST
;
; URI Request URI
;
; [ONC8DATA] Closed root of a variable containing body of the
; request message. If this parameter is defined, not
; empty, and the referenced variable is defined then
; the POST request is generated. Otherwise, the GET
; request is sent.
;
; [.ONC8HDR] Reference to a local variable containing header
; values
;
; Return values:
; <0 Error Code^Description
; "GET" Ok
; "POST" Ok
;
REQUEST(URI,ONC8DATA,ONC8HDR) ;
N CRLF,DFLTHDR,I,J,STATUS
S CRLF=$C(13,10)
;--- Check for default header(s)
S DFLTHDR("CONTENT-LENGTH")=""
S DFLTHDR("CONTENT-TYPE")=""
S DFLTHDR("USER-AGENT")=""
S I=""
F S I=$O(ONC8HDR(I)) Q:I="" K DFLTHDR($$UP^XLFSTR(I))
S:$D(DFLTHDR("USER-AGENT")) ONC8HDR("User-Agent")="VistA/1.0"
;--- Send the request
U IO
I $G(ONC8DATA)'="",$D(@ONC8DATA)>1 S STATUS="POST" D
. S:$D(DFLTHDR("CONTENT-TYPE")) ONC8HDR("Content-Type")="text/html"
. D:$D(DFLTHDR("CONTENT-LENGTH"))
. . S ONC8HDR("Content-Length")=$$DATASIZE(ONC8DATA,$L(CRLF))
. W "POST "_URI_" HTTP/1.0",CRLF,!
. ;--- Header
. S I=""
. F S I=$O(ONC8HDR(I)) Q:I="" W I_": "_ONC8HDR(I),CRLF,!
. ;--- Body
. S I=""
. F S I=$O(@ONC8DATA@(I)) Q:I="" D
. . W CRLF,$G(@ONC8DATA@(I)),!
. . S J=""
. . F S J=$O(@ONC8DATA@(I,J)) Q:J="" W $G(@ONC8DATA@(I,J)),!
E S STATUS="GET" D
. W "GET "_URI_" HTTP/1.0",CRLF,!
. S I=""
. F S I=$O(ONC8HDR(I)) Q:I="" W I_": "_ONC8HDR(I),CRLF,!
. W CRLF,!
U $P
Q STATUS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCX10A 7341 printed Apr 09, 2024@21:24:39 Page 2
ONCX10A ;HCIOFO/SG - HTTP 1.0 CLIENT (TOOLS) ; 8/11/04 8:26am
+1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
+2 ;
+3 QUIT
+4 ;
+5 ;***** APPENDS RECEIVED PIECE OF DATA TO THE DESTINATION BUFFER
+6 ;
+7 ; BUF Received data
+8 ;
+9 ; [NEWLINE] Start a new line after appending the data
+10 ;
+11 ; The ONC8BUF, ONC8DST, ONC8IS, ONC8MBL, ONC8PTR, and ONC8SL
+12 ; variables must be properly initialized before calling this
+13 ; procedure (see the $$RECEIVE^ONCX10A for details).
+14 ;
APPEND(BUF,NEWLINE) ;
+1 NEW BASE,L
+2 SET L=$LENGTH(BUF)
if $ASCII(BUF,L)=13
SET L=L-1
+3 ;--- Append the data
+4 IF L'<ONC8SL
Begin DoDot:1
+5 SET ONC8BUF=ONC8BUF_$EXTRACT(BUF,1,ONC8SL)
SET L=L-ONC8SL
+6 SET BASE=1
+7 FOR
Begin DoDot:2
+8 IF 'ONC8IS
SET @ONC8DST@(ONC8PTR)=ONC8BUF
+9 IF '$TEST
SET @ONC8DST@(ONC8PTR,ONC8IS)=ONC8BUF
+10 SET BASE=BASE+ONC8SL
SET ONC8IS=ONC8IS+1
SET ONC8SL=ONC8MBL
+11 SET ONC8BUF=$EXTRACT(BUF,BASE,BASE+ONC8SL-1)
SET L=L-ONC8SL
End DoDot:2
if L'>0
QUIT
+12 SET ONC8SL=-L
End DoDot:1
+13 IF '$TEST
SET ONC8BUF=ONC8BUF_$EXTRACT(BUF,1,L)
SET ONC8SL=ONC8SL-L
+14 ;--- Flush the buffer and start a new line
+15 IF $GET(NEWLINE)
Begin DoDot:1
+16 IF 'ONC8IS
SET @ONC8DST@(ONC8PTR)=ONC8BUF
QUIT
+17 SET @ONC8DST@(ONC8PTR,ONC8IS)=ONC8BUF
End DoDot:1
SET ONC8BUF=""
SET ONC8IS=0
SET ONC8PTR=ONC8PTR+1
SET ONC8SL=ONC8MBL
+18 QUIT
+19 ;
+20 ;***** CALCULATES NUMBER OF BYTES IN THE MESSAGE BODY
+21 ;
+22 ; ONC8DATA Closed root of a variable containing body
+23 ; of the message
+24 ;
+25 ; NLS Length of the line terminator(s)
+26 ;
DATASIZE(ONC8DATA,NLS) ;
+1 NEW SIZE
+2 SET SIZE=0
+3 FOR
SET I=$ORDER(@ONC8DATA@(I))
if I=""
QUIT
Begin DoDot:1
+4 SET SIZE=SIZE+$LENGTH($GET(@ONC8DATA@(I)))
+5 SET J=""
+6 FOR
SET J=$ORDER(@ONC8DATA@(I,J))
if J=""
QUIT
Begin DoDot:2
+7 SET SIZE=SIZE+$LENGTH($GET(@ONC8DATA@(I,J)))
End DoDot:2
End DoDot:1
SET SIZE=SIZE+NLS
+8 QUIT $SELECT(SIZE>0:SIZE-NLS,1:0)
+9 ;
+10 ;***** PROCESSES THE HTTP HEADER
+11 ;
+12 ; .ONC8H Reference to a local array containing
+13 ; the raw header data
+14 ;
+15 ; .ONC8HDR Reference to a local variable where the parsed
+16 ; header will be returned
+17 ;
+18 ; Return values:
+19 ; <0 Error Descriptor
+20 ; >0 HTTP Status Code^Description
+21 ;
+1 NEW BUF,I,NAME,TAB,TMP
+2 SET ONC8HDR=$$NORMSTAT($GET(ONC8H(1)))
SET TAB=$CHAR(9)
+3 FOR I=2:1
SET BUF=$TRANSLATE($GET(ONC8H(I)),TAB," ")
if BUF=""
QUIT
Begin DoDot:1
+4 ;--- Continuation of the previous header line
+5 IF $EXTRACT(BUF,1)=" "
if $GET(NAME)'=""
Begin DoDot:2
+6 SET TMP=$$TRIM^XLFSTR(BUF)
+7 if TMP'=""
SET ONC8HDR(NAME)=ONC8HDR(NAME)_" "_TMP
End DoDot:2
QUIT
+8 ;--- New header line
+9 SET NAME=$$UP^XLFSTR($$TRIM^XLFSTR($PIECE(BUF,":")))
+10 if NAME'=""
SET ONC8HDR(NAME)=$$TRIM^XLFSTR($PIECE(BUF,":",2,999))
End DoDot:1
+11 QUIT $PIECE(ONC8HDR," ",2)_U_$PIECE(ONC8HDR," ",3,999)
+12 ;
+13 ;***** NORMALIZES THE HTTP STATUS LINE
NORMSTAT(STATUS) ;
+1 NEW I,J1,J2,TMP
+2 ;--- Remove leading and trailing spaces
+3 SET STATUS=$$TRIM^XLFSTR(STATUS)
+4 ;--- Replace groups of consecutive spaces with single spaces
+5 SET J2=1
+6 FOR I=1,2
Begin DoDot:1
+7 SET J1=$FIND(STATUS," ",J2)
if 'J1
QUIT
+8 FOR J2=J1:1
if $EXTRACT(STATUS,J2)'=" "
QUIT
+9 SET $EXTRACT(STATUS,J1,J2-1)=""
End DoDot:1
if 'J1
QUIT
+10 ;--- Return normalized status line
+11 QUIT STATUS
+12 ;
+13 ;***** RECEIVES AN HTTP RESPONSE
+14 ;
+15 ; TIMEOUT Timeout value (in seconds) for TCPIP input.
+16 ;
+17 ; [ONC8DATA] Closed root of the variable where the message
+18 ; body is returned. See the $$GETURL^ONCX10
+19 ; for details.
+20 ;
+21 ; [.ONC8HDR] Reference to a local variable where the parsed
+22 ; headers will be returned. See the $$GETURL^ONCX10
+23 ; for details.
+24 ;
RECEIVE(TIMEOUT,ONC8DATA,ONC8HDR) ;
+1 ; ONC8BUF Work buffer where the current line is being built
+2 ; ONC8DST Closed root of the current destination buffer used
+3 ; by the APPEND^ONCX10A
+4 ; ONC8H Temporary buffer for the raw HTTP header
+5 ; ONC8IS Subscript of the current continuation sub-node in
+6 ; the destination buffer (if 0 then the current main
+7 ; node is used)
+8 ; ONC8MBL Maximum buffer length
+9 ; ONC8PTR Subscript of the current node in the dest. buffer
+10 ; ONC8SL Number of available bytes in the current (sub)node
+11 ;
+12 NEW $ESTACK,$ETRAP,BLCHS,BUF,EXIT,I1,I2,MBL,ONC8BUF,ONC8DST,ONC8H,ONC8IS,ONC8MBL,ONC8PTR,ONC8SL,RTO,STATUS,TMP,X
+13 SET BLCHS=$CHAR(9,10,12,13)_" "
SET ONC8MBL=245
+14 if $GET(ONC8DATA)'=""
KILL @ONC8DATA
KILL ONC8HDR
+15 SET ONC8BUF=""
SET ONC8IS=0
SET ONC8PTR=1
SET ONC8SL=ONC8MBL
+16 ;--- Setup the error processing
+17 SET X="RCVERR^ONCX10A"
SET @^%ZOSF("TRAP")
SET $ETRAP=""
+18 ;--- Receive the header (until the first empty line)
+19 USE IO
+20 SET ONC8DST="ONC8H"
SET (EXIT,RTO)=0
+21 FOR
READ BUF#ONC8MBL:TIMEOUT
SET RTO='$TEST
Begin DoDot:1
+22 SET I1=1
+23 FOR
SET I2=$FIND(BUF,$CHAR(10),I1)
if 'I2
QUIT
Begin DoDot:2
+24 SET TMP=$EXTRACT(BUF,I1,I2-2)
DO APPEND(TMP,1)
SET I1=I2
+25 if $TRANSLATE(TMP,BLCHS)=""
SET EXIT=1
End DoDot:2
if EXIT
QUIT
+26 if 'EXIT
DO APPEND($EXTRACT(BUF,I1,ONC8MBL))
End DoDot:1
if EXIT!RTO
QUIT
+27 ;--- A header must end with an empty line.
+28 ;--- Otherwise, there was a timeout.
+29 if 'EXIT
QUIT $$ERROR^ONCXERR(-7)
+30 ;--- Remove ending of the header from the buffer. The buffer
+31 ;--- can contain beginning of the message body.
+32 if I1>1
SET $EXTRACT(BUF,1,I1-1)=""
+33 ;--- Process the header
+34 SET STATUS=$$HEADER(.ONC8H,.ONC8HDR)
+35 ;--- Receive the message body
+36 if $GET(ONC8DATA)'=""
Begin DoDot:1
+37 NEW CNTLEN,RDLEN
+38 SET RDLEN=ONC8MBL
+39 ;--- Check for Content-Length header
+40 IF $DATA(ONC8HDR("CONTENT-LENGTH"))
Begin DoDot:2
+41 SET CNTLEN=+ONC8HDR("CONTENT-LENGTH")
+42 if CNTLEN<ONC8MBL
SET RDLEN=CNTLEN
End DoDot:2
if CNTLEN'>0
QUIT
+43 IF '$TEST
SET CNTLEN=-1
+44 ;--- Read the content
+45 SET ONC8DST=ONC8DATA
SET RTO=0
+46 FOR
Begin DoDot:2
+47 if CNTLEN>0
Begin DoDot:3
+48 SET CNTLEN=CNTLEN-$LENGTH(BUF)
if CNTLEN<0
SET CNTLEN=0
+49 if CNTLEN<RDLEN
SET RDLEN=CNTLEN
End DoDot:3
+50 SET I1=1
+51 FOR
SET I2=$FIND(BUF,$CHAR(10),I1)
if 'I2
QUIT
Begin DoDot:3
+52 DO APPEND($EXTRACT(BUF,I1,I2-2),1)
SET I1=I2
End DoDot:3
+53 DO APPEND($EXTRACT(BUF,I1,ONC8MBL))
End DoDot:2
if 'CNTLEN!RTO
QUIT
READ BUF#RDLEN:TIMEOUT
SET RTO='$TEST
End DoDot:1
+54 ;--- Flush the buffers and process the header (only if necessary)
RCVERR USE $PRINCIPAL
+1 DO APPEND("",1)
+2 if $GET(STATUS)=""
SET STATUS=$$HEADER(.ONC8H,.ONC8HDR)
+3 QUIT STATUS
+4 ;
+5 ;***** SENDS THE HTTP REQUEST
+6 ;
+7 ; URI Request URI
+8 ;
+9 ; [ONC8DATA] Closed root of a variable containing body of the
+10 ; request message. If this parameter is defined, not
+11 ; empty, and the referenced variable is defined then
+12 ; the POST request is generated. Otherwise, the GET
+13 ; request is sent.
+14 ;
+15 ; [.ONC8HDR] Reference to a local variable containing header
+16 ; values
+17 ;
+18 ; Return values:
+19 ; <0 Error Code^Description
+20 ; "GET" Ok
+21 ; "POST" Ok
+22 ;
REQUEST(URI,ONC8DATA,ONC8HDR) ;
+1 NEW CRLF,DFLTHDR,I,J,STATUS
+2 SET CRLF=$CHAR(13,10)
+3 ;--- Check for default header(s)
+4 SET DFLTHDR("CONTENT-LENGTH")=""
+5 SET DFLTHDR("CONTENT-TYPE")=""
+6 SET DFLTHDR("USER-AGENT")=""
+7 SET I=""
+8 FOR
SET I=$ORDER(ONC8HDR(I))
if I=""
QUIT
KILL DFLTHDR($$UP^XLFSTR(I))
+9 if $DATA(DFLTHDR("USER-AGENT"))
SET ONC8HDR("User-Agent")="VistA/1.0"
+10 ;--- Send the request
+11 USE IO
+12 IF $GET(ONC8DATA)'=""
IF $DATA(@ONC8DATA)>1
SET STATUS="POST"
Begin DoDot:1
+13 if $DATA(DFLTHDR("CONTENT-TYPE"))
SET ONC8HDR("Content-Type")="text/html"
+14 if $DATA(DFLTHDR("CONTENT-LENGTH"))
Begin DoDot:2
+15 SET ONC8HDR("Content-Length")=$$DATASIZE(ONC8DATA,$LENGTH(CRLF))
End DoDot:2
+16 WRITE "POST "_URI_" HTTP/1.0",CRLF,!
+17 ;--- Header
+18 SET I=""
+19 FOR
SET I=$ORDER(ONC8HDR(I))
if I=""
QUIT
WRITE I_": "_ONC8HDR(I),CRLF,!
+20 ;--- Body
+21 SET I=""
+22 FOR
SET I=$ORDER(@ONC8DATA@(I))
if I=""
QUIT
Begin DoDot:2
+23 WRITE CRLF,$GET(@ONC8DATA@(I)),!
+24 SET J=""
+25 FOR
SET J=$ORDER(@ONC8DATA@(I,J))
if J=""
QUIT
WRITE $GET(@ONC8DATA@(I,J)),!
End DoDot:2
End DoDot:1
+26 IF '$TEST
SET STATUS="GET"
Begin DoDot:1
+27 WRITE "GET "_URI_" HTTP/1.0",CRLF,!
+28 SET I=""
+29 FOR
SET I=$ORDER(ONC8HDR(I))
if I=""
QUIT
WRITE I_": "_ONC8HDR(I),CRLF,!
+30 WRITE CRLF,!
End DoDot:1
+31 USE $PRINCIPAL
+32 QUIT STATUS
