XTHCDEM ;HCIOFO/SG - HTTP 1.0 CLIENT (DEMO) ; Oct 01, 2025 10:54
;;7.3;TOOLKIT;**123,162**;Apr 25, 1995;Build 4
;Per VA Directive 6402, this routine should not be modified.
;
;##### DEMO ENTRY POINT
;
; The ^TMP($J,"XTHC") global node is used by the entry point.
;
DEMO(OPTION) ;XT162
N BODY,DIR,DIRUT,DTOUT,DUOUT,HEADER,RC,URL,X,Y
S BODY=$NA(^TMP($J,"XTHC"))
S OPTION=$G(OPTION) ;XT162
I OPTION=1 D
. S URL="https://www.amazon.com" ;native https
E I OPTION=2 D
. S URL="https://www.howsmyssl.com/" ;native https
E I OPTION=3 D
. S URL="https://postman-echo.com/get" ;native https
E I OPTION=4 D
. S URL="https://httpbin.org/get"
E I OPTION=5 D
. S URL="http://httpforever.com" ;permanent http site
E S URL="http://www.hardhats.org" ;this will redirect
;
S RC=0
F D Q:RC
. K @BODY,HEADER W !
. ;--- Request a URL from the user
. K DIR S DIR(0)="F"
. S DIR("A")="URL",DIR("B")=URL
. D ^DIR I $D(DIRUT) S RC=1 Q
. S URL=$$TRIM^XLFSTR(Y)
. ;--- Request the resource
. S RC=$$GETURL^XTHC10(URL,,BODY,.HEADER)
. I RC<0 W !,RC S RC=0 Q ; D PRTERRS^XTERROR1(RC) S RC=0 Q
. ;--- Print the data
. D PRINT(BODY,.HEADER)
. S RC=0
;
;--- Cleanup
K @BODY
Q
;
;+++++ PRINTS THE RESPONSE
PRINT(XTHC8DAT,HEADER) ;
N I,J
;---
I $D(HEADER)>0 D Q:$$PAGE
. W @IOF,"----- HTTP HEADER -----",!!
. W $G(HEADER),!
. S I=""
. F S I=$O(HEADER(I)) Q:I="" W I_"="_HEADER(I),!
;---
D:$D(@XTHC8DAT)>1
. W @IOF,"----- MESSAGE XTHC8DAT -----",!!
. S I=""
. F S I=$O(@XTHC8DAT@(I)) Q:I="" W @XTHC8DAT@(I) D W !
. . S J="" F S J=$O(@XTHC8DAT@(I,J)) Q:J="" W @XTHC8DAT@(I,J)
Q
;
PAGE() ;Page break
N DIR,DIROUT,DTOUT,DUOUT
S DIR(0)="E"
D ^DIR
Q $S($D(DUOUT):1,$D(DTOUT):1,1:0)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTHCDEM 1805 printed Sep 17, 2026@21:27:07 Page 2
XTHCDEM ;HCIOFO/SG - HTTP 1.0 CLIENT (DEMO) ; Oct 01, 2025 10:54
+1 ;;7.3;TOOLKIT;**123,162**;Apr 25, 1995;Build 4
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;##### DEMO ENTRY POINT
+5 ;
+6 ; The ^TMP($J,"XTHC") global node is used by the entry point.
+7 ;
DEMO(OPTION) ;XT162
+1 NEW BODY,DIR,DIRUT,DTOUT,DUOUT,HEADER,RC,URL,X,Y
+2 SET BODY=$NAME(^TMP($JOB,"XTHC"))
+3 ;XT162
SET OPTION=$GET(OPTION)
+4 IF OPTION=1
Begin DoDot:1
+5 ;native https
SET URL="https://www.amazon.com"
End DoDot:1
+6 IF '$TEST
IF OPTION=2
Begin DoDot:1
+7 ;native https
SET URL="https://www.howsmyssl.com/"
End DoDot:1
+8 IF '$TEST
IF OPTION=3
Begin DoDot:1
+9 ;native https
SET URL="https://postman-echo.com/get"
End DoDot:1
+10 IF '$TEST
IF OPTION=4
Begin DoDot:1
+11 SET URL="https://httpbin.org/get"
End DoDot:1
+12 IF '$TEST
IF OPTION=5
Begin DoDot:1
+13 ;permanent http site
SET URL="http://httpforever.com"
End DoDot:1
+14 ;this will redirect
IF '$TEST
SET URL="http://www.hardhats.org"
+15 ;
+16 SET RC=0
+17 FOR
Begin DoDot:1
+18 KILL @BODY,HEADER
WRITE !
+19 ;--- Request a URL from the user
+20 KILL DIR
SET DIR(0)="F"
+21 SET DIR("A")="URL"
SET DIR("B")=URL
+22 DO ^DIR
IF $DATA(DIRUT)
SET RC=1
QUIT
+23 SET URL=$$TRIM^XLFSTR(Y)
+24 ;--- Request the resource
+25 SET RC=$$GETURL^XTHC10(URL,,BODY,.HEADER)
+26 ; D PRTERRS^XTERROR1(RC) S RC=0 Q
IF RC<0
WRITE !,RC
SET RC=0
QUIT
+27 ;--- Print the data
+28 DO PRINT(BODY,.HEADER)
+29 SET RC=0
End DoDot:1
if RC
QUIT
+30 ;
+31 ;--- Cleanup
+32 KILL @BODY
+33 QUIT
+34 ;
+35 ;+++++ PRINTS THE RESPONSE
PRINT(XTHC8DAT,HEADER) ;
+1 NEW I,J
+2 ;---
+3 IF $DATA(HEADER)>0
Begin DoDot:1
+4 WRITE @IOF,"----- HTTP HEADER -----",!!
+5 WRITE $GET(HEADER),!
+6 SET I=""
+7 FOR
SET I=$ORDER(HEADER(I))
if I=""
QUIT
WRITE I_"="_HEADER(I),!
End DoDot:1
if $$PAGE
QUIT
+8 ;---
+9 if $DATA(@XTHC8DAT)>1
Begin DoDot:1
+10 WRITE @IOF,"----- MESSAGE XTHC8DAT -----",!!
+11 SET I=""
+12 FOR
SET I=$ORDER(@XTHC8DAT@(I))
if I=""
QUIT
WRITE @XTHC8DAT@(I)
Begin DoDot:2
+13 SET J=""
FOR
SET J=$ORDER(@XTHC8DAT@(I,J))
if J=""
QUIT
WRITE @XTHC8DAT@(I,J)
End DoDot:2
WRITE !
End DoDot:1
+14 QUIT
+15 ;
PAGE() ;Page break
+1 NEW DIR,DIROUT,DTOUT,DUOUT
+2 SET DIR(0)="E"
+3 DO ^DIR
+4 QUIT $SELECT($DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
+5 ;
