XTHCUTL ;ISF/RWF - HTTP 1.0 CLIENT Utilities ; 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.
Q
;<LI> <A HREF="#Payroll_&_Personnel" TITLE="Payroll & Personnel Links">Payroll & Personnel</A> </LI>
;
DECODE(STR) ;DeCode a string =" ", <=<, >=>, =" "
N I,J,K ;XT162
I $G(STR)="" Q "" ;XT162
S I=0
F S I=$F(STR,"&",I) Q:'I S J=$P($E(STR,I,I+5),";"),J=$$LOW^XLFSTR(J),K=$S(J="nbsp":" ",J="lt":"<",J="gt":">",J="amp":"&",J="apos":"'",J="quot":"""",$E(J)="#":$E(J,2,4),1:"") D:$L(K)
. I +K S K=$C(+K) ;A The decimal value in ISO-latin-1 for A
. S STR=$E(STR,1,I-2)_K_$E(STR,I+$L(J)+1,$L(STR))
Q STR
;
UNHEX(HH) ;function - decode one pair of hex digits to ASCII char
I $G(HH)="" Q "" ;XT162
S HH=$TR(HH,"abcdef","ABCDEF")
I $TR(HH,"0123456789ABCDEF")'="" Q "???" ;-- error - bad hex code --;
S HH=$TR(HH,"ABCDEF",":;<=>?")
Q $C($$UNHEXD($E(HH,1))*16+$$UNHEXD($E(HH,2)))
;
UNHEXD(X) ;function - convert hex digit back to decimal
I $G(X)="" Q "" ;XT162
Q $A(X)-48
;
QUOTE ;
F I=I+1:1 S CH=$E(STR,I) Q:CH=""!(CH=Q)
I $E(STR,I+1)=Q S I=I+1 G QUOTE
Q
;
TEST ;Unit Tests
N STR ;XT162
S STR="[ <&"'> ]m" I $$DECODE(STR)'="[ <&""'> ]m" W !,"Fail: ",STR
S STR="0123456789ABCDEF" I $$DECODE(STR)'="0123456789ABCDEF" W !,"Fail: ",STR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTHCUTL 1492 printed Sep 17, 2026@21:27:09 Page 2
XTHCUTL ;ISF/RWF - HTTP 1.0 CLIENT Utilities ; 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 QUIT
+4 ;<LI> <A HREF="#Payroll_&_Personnel" TITLE="Payroll & Personnel Links">Payroll & Personnel</A> </LI>
+5 ;
DECODE(STR) ;DeCode a string =" ", <=<, >=>, =" "
+1 ;XT162
NEW I,J,K
+2 ;XT162
IF $GET(STR)=""
QUIT ""
+3 SET I=0
+4 FOR
SET I=$FIND(STR,"&",I)
if 'I
QUIT
SET J=$PIECE($EXTRACT(STR,I,I+5),";")
SET J=$$LOW^XLFSTR(J)
SET K=$SELECT(J="nbsp":" ",J="lt":"<",J="gt":">",J="amp":"&",J="apos":"'",J="quot":"""",$EXTRACT(J)="#":$EXTRACT(J,2,4),1:"")
if $LENGTH(K)
Begin DoDot:1
+5 ;A The decimal value in ISO-latin-1 for A
IF +K
SET K=$CHAR(+K)
+6 SET STR=$EXTRACT(STR,1,I-2)_K_$EXTRACT(STR,I+$LENGTH(J)+1,$LENGTH(STR))
End DoDot:1
+7 QUIT STR
+8 ;
UNHEX(HH) ;function - decode one pair of hex digits to ASCII char
+1 ;XT162
IF $GET(HH)=""
QUIT ""
+2 SET HH=$TRANSLATE(HH,"abcdef","ABCDEF")
+3 ;-- error - bad hex code --;
IF $TRANSLATE(HH,"0123456789ABCDEF")'=""
QUIT "???"
+4 SET HH=$TRANSLATE(HH,"ABCDEF",":;<=>?")
+5 QUIT $CHAR($$UNHEXD($EXTRACT(HH,1))*16+$$UNHEXD($EXTRACT(HH,2)))
+6 ;
UNHEXD(X) ;function - convert hex digit back to decimal
+1 ;XT162
IF $GET(X)=""
QUIT ""
+2 QUIT $ASCII(X)-48
+3 ;
QUOTE ;
+1 FOR I=I+1:1
SET CH=$EXTRACT(STR,I)
if CH=""!(CH=Q)
QUIT
+2 IF $EXTRACT(STR,I+1)=Q
SET I=I+1
GOTO QUOTE
+3 QUIT
+4 ;
TEST ;Unit Tests
+1 ;XT162
NEW STR
+2 SET STR="[ <&"'> ]m"
IF $$DECODE(STR)'="[ <&""'> ]m"
WRITE !,"Fail: ",STR
+3 SET STR="0123456789ABCDEF"
IF $$DECODE(STR)'="0123456789ABCDEF"
WRITE !,"Fail: ",STR
+4 QUIT
