XLFNSLK ;ISF/RWF,ISD/HGW - Calling a DNS server for name lookup ;07/11/14 11:18
;;8.0;KERNEL;**142,151,425,638**;Jul 10, 1995;Build 16
;Per VHA Directive 2004-038, this routine should not be modified.
;
TEST ;Test entry
N XLF,XL1,XL4,XL6,XNAME,Y,I S (XLF,XL4,XL6)=""
R !,"Enter an IP address to lookup: www.domain.ext//",XNAME:DTIME S:XNAME="" XNAME="www.domain.ext" Q:XNAME["^"
S XL1=XNAME
W !!,"Looking up IPv4 address: ",XL1 D NS(.XLF,XL1,"A",.XL4)
S XL1="XL4" F S XL1=$Q(@XL1) Q:XL1="" W !,XL1," = ",@XL1
S Y="" F S Y=$O(XLF("B",Y)) Q:Y="" W !,?5,Y," > ",XLF("B",Y)
S XL1=XNAME
W !!,"Looking up IPv6 address: ",XL1 D NS(.XLF,XL1,"AAAA",.XL6)
S XL1="XL6" F S XL1=$Q(@XL1) Q:XL1="" W !,XL1," = ",@XL1
S Y="" F S Y=$O(XLF("B",Y)) Q:Y="" W !,?5,Y," > ",XLF("B",Y)
W !
Q
;
ADDRESS(N,T) ;Get a IP address from a name
N XLF,Y,I S XLF="",T=$G(T,"A")
I $$VERSION^XLFIPV S T=$G(T,"AAAA") ; change default from "A" to "AAAA" if VistA has IPv6 enabled
I ^%ZOSF("OS")["OpenM",T="A" D Q $P(Y,",")
. X "S Y=$ZU(54,13,N)" ; $ZU(54,13,N) is gethostbyname(N) IPv4 address nslookup
D NS(.XLF,N,T)
S Y="" F I=1:1:XLF("ANCOUNT") S:$D(XLF("AN"_I_"DATA")) Y=Y_XLF("AN"_I_"DATA")_","
Q $E(Y,1,$L(Y)-1)
;
MAIL(RET,N) ;Get the MX address for a domain
;RET is the return array
N XLF,Y,I,T S XLF="",T="MX"
D NS(.XLF,N,T)
S RET=0,I=0 F S I=$O(XLF("P",I)) Q:I'>0 D
. S N=XLF("P",I),RET(I)=N_"^"_$G(XLF("B",N)),RET=RET+1
Q
;
NS(XL,NAME,QTYPE,XLFLOG) ;NAME LOOKUP
;XL is the return array, NAME is the name to lookup,
;QTYPE is type of lookup, XLFLOG is a debug array returned.
N RI,DNS,CNT,POP N:'$D(XLFLOG) XLFLOG S XL("ANCOUNT")=0,CNT=1
D SAVEDEV
NS2 S DNS=$$GETDNS(CNT) I DNS="" G EXIT
D LOG("Call server: "_DNS)
D CALL^%ZISTCP(DNS,53) I POP S CNT=CNT+1 G NS2
D LOG("Got connection, Send message")
D BUILD(NAME,$G(QTYPE,"A")),LOG("Wait for reply") ; Uses "A" type for IPv4 if QTYPE is not defined
;Close part of READ
D READ,DECODE
D RESDEV,LOG("Returned question: "_$G(XL("QD1NAME")))
Q
EXIT D RESDEV
Q
;
BUILD(Y,T) ;BUILD A QUERY
; ID,PARAM,#of?, #ofA, #of Auth, #of add,
N X,%,MSG,I
S X=" M"_$C(1,0)_$C(0,1)_$C(0,0)_$C(0,0)_$C(0,0) ;Header
I $E(Y,$L(Y))'="." S:$E(Y,$L(Y))'="." Y=Y_"." ;future fix: implies IPv4 address for DNS server
F I=1:1:$L(Y,".") S %=$P(Y,".",I) S:$L(%) X=X_$C($L(%))_% ;Address ;future fix: implies IPv4 address for DNS server
S X=X_$C(0) ;End of address ;future fix: implies IPv4 address for DNS server
;Type A=1, NS=2, CNAME=5, MX=15, AAAA=28 ;p638 Added "AAAA" for IPv6
S MSG=X_$C(0,$$TYPECODE(T))_$C(0,1) ;type and class
D LOG("msg: "_MSG)
U IO S %=$L(MSG) W $C(%\256,%#256)_MSG,!
Q
READ ;
N L1,L2,X,$ET S $ET="G RDERR" K RI S RI=0
U IO R L1#2:20 I '$T D LOG("Time-out") G RDERR
S RI=$A(L1,1)*256+$A(L1,2) ;get msg length
F I=1:1:6 R L2#2:20 Q:'$T S XL($P("ID^CODE^QDCOUNT^ANCOUNT^NSCOUNT^ARCOUNT","^",I))=$S(I>2:$$WBN(L2),I=2:$$BIN16(L2),1:L2)
I '$T D LOG("Time-out") G RDERR
D LOG("Return msg length: "_RI)
F I=13:1:RI U IO R *X:20 Q:'$T S RI(I)=X ;or use X#1 and $A(X)
RDERR ;End of read
D CLOSE^%ZISTCP
Q
DECODE ;
N I,IX,X,Y,Z,NN,NN2 Q:RI'>7
I $G(XL("ID"))'=" M" S XL("ERR")="Bad Response" D LOG(XL("ERR")) Q
;Decode the header
S Z=XL("CODE"),XL("QR")=$E(Z,1),XL("Opcode")=$E(Z,2,5),XL("AA")=$E(Z,6),XL("TC")=$E(Z,7),XL("RD")=$E(Z,8),XL("RA")=$E(Z,9),XL("RCODE")=$E(Z,13,16)
;The Question section
S IX=13
F NN2=1:1:XL("QDCOUNT") D QD("QD"_NN2)
F NN="AN","NS","AR" I $G(XL(NN_"COUNT")) F NN2=1:1:XL(NN_"COUNT") D RR(NN_NN2)
Q
;
QD(NSP) ;Decode the Question section
N Y
S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y
S XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
S XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
Q
RR(NSP) ;
N Y,NA
S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y,NA=Y
S XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
S XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
S Y=RI(IX)*256+RI(IX+1),Y=Y*256+RI(IX+2),Y=Y*256+RI(IX+3)
S XL(NSP_"TTL")=Y,IX=IX+4
S (X,XL(NSP_"LENGTH"))=$$BN(RI(IX),RI(IX+1)),IX=IX+2 Q:X=0
I XL(NSP_"TYPE")=1 D ; IPv4 address
. S XL(NSP_"DATA")=RI(IX)_"."_RI(IX+1)_"."_RI(IX+2)_"."_RI(IX+3),XL("B",NA)=XL(NSP_"DATA")
I XL(NSP_"TYPE")=28 D ; IPv6 address
. S XL(NSP_"DATA")=$$H1(RI(IX))_$$H1(RI(IX+1))_":"_$$H1(RI(IX+2))_$$H1(RI(IX+3))_":"
. S XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+4))_$$H1(RI(IX+5))_":"_$$H1(RI(IX+6))_$$H1(RI(IX+7))_":"
. S XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+8))_$$H1(RI(IX+9))_":"_$$H1(RI(IX+10))_$$H1(RI(IX+11))_":"
. S XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+12))_$$H1(RI(IX+13))_":"_$$H1(RI(IX+14))_$$H1(RI(IX+15))
. S XL("B",NA)=XL(NSP_"DATA")
I XL(NSP_"TYPE")=15 D MX(IX) ; MX entry
S IX=IX+XL(NSP_"LENGTH")
Q
NAME(I,NM,F) ;Decode a NAME section
N P,T,Y,X S NM=$G(NM) S:F T=0
F S X=RI(I) S:(X=0)&F T=T+1 Q:X=0 D Q:X=0 ;Use X as flag to escape recursion.
. I (X\64)=3 S X=$$NAME((X#64)*256+RI(I+1)+1,.NM,0),X=0 S:F T=T+2 Q
. S NM=NM_$$PART(I+1,X),I=I+X+1 S:F T=T+X+1
Q $G(T)
;
MX(IX) ;Hide IX changes
N Y S Y=$$BN(RI(IX),RI(IX+1))
F Q:'$D(XL("P",Y)) S Y=Y+1
S XL(NSP_"PREF")=Y,IX=IX+2
S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y,XL("P",XL(NSP_"PREF"))=Y
Q
;
BN(Z1,Z2) ;Convert two binary char 16 bit number into ASCII number
Q Z1*256+Z2
;
WBN(Z1) ;Convert two byte string to a ASCII number
Q $A(Z1,1)*256+$A(Z1,2)
;
H2(Z2) ;Convert 2 byte string to HEX
N B S B=$A(Z2,1)*256+$A(Z2,2)
Q $$H(B)
;
H1(Z1) ;Convert decimal number <= 256 to two digit HEX number
N Y S Y=$$CNV^XLFUTL(Z1,16)
Q $$RJ^XLFSTR(Y,2,"0")
;
H(Z1) Q $$BASE^XLFUTL(Z1,10,16)
;
BIN16(S) ;Convert two byte string to 16 bit binary
N K,Y S S=$A(S,1)*256+$A(S,2),Y=""
F K=0:1:15 S Y=(S\(2**K)#2)_Y
Q Y
;
PART(S,L) ;
N R,A S R="" F A=S:1:S+L-1 S R=R_$C(RI(A))
Q R_"."
;
TYPECODE(T) ;
;1=A:IPv4 address,2=NS:nameserver,5=CNAME,15=MX:mail exchange,28=AAAA:IPv6 address ;p638 Added "AAAA" for IPv6
I +T Q $S(T=1:"A",T=2:"NS",T=5:"CNAME",T=15:"MX",T=28:"AAAA",1:"ZZ") ;p638 Added "AAAA" for IPv6
Q $S(T="A":1,T="NS":2,T="CNAME":5,T="MX":15,T="AAAA":28,1:1) ;p638 Added "AAAA" for IPv6
;
CLASS(T) ;
Q $S(T=1:"IN",1:"ZZ")
;
GETDNS(I) ;Get the address of our DNS
N L S L=$G(^XTV(8989.3,1,"DNS"))
Q $P(L,",",I)
;
SHOW ;LIST RI AND XL
S O1=RI\3+1,O2=O1*2
F I=1:1:O1 D SW(0,"RI("_I_")=",$G(RI(I))),SW(30,"RI("_(I+O1)_")=",$G(RI(I+O1))),SW(60,"RI("_(I+O2)_")=",$G(RI(I+O2))) W !
Q
SW(T,H,V) ;
W ?T,$J(H,8),V
Q
SAVEDEV ;Save calling device
D:'$D(IO(0)) HOME^%ZIS D SAVDEV^%ZISUTL("XLFNSLK")
Q
RESDEV ;Restore calling device
D USE^%ZISUTL("XLFNSLK"),RMDEV^%ZISUTL("XLFNSLK")
K IO("CLOSE")
Q
LOG(M) ;Log Debug messages
S XLFLOG=$G(XLFLOG)+1,XLFLOG(XLFLOG)=M
Q
;
POST ;Stuff a DNS address during install POST init.
N DIC,DR,DIQ,XLF,DIE
S XLF=$P($$PARAM^HLCS2,U,3)
I XLF="T" D BMES^XPDUTL("Test Account DNS address not installed.") Q
S DIC=8989.3,DR=51,DA=1,DIQ="XLF(" D EN^DIQ1 I $L(XLF(8989.3,1,51)) Q
S DR="51///127.0.0.1",DIE="^XTV(8989.3,",DA=1 D ^DIE
D BMES^XPDUTL("DNS address installed.")
Q
XLFNSLK ;ISF/RWF,ISD/HGW - Calling a DNS server for name lookup ;07/11/14 11:18
+1 ;;8.0;KERNEL;**142,151,425,638**;Jul 10, 1995;Build 16
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
TEST ;Test entry
+1 NEW XLF,XL1,XL4,XL6,XNAME,Y,I
SET (XLF,XL4,XL6)=""
+2 READ !,"Enter an IP address to lookup: www.domain.ext//",XNAME:DTIME
IF XNAME=""
SET XNAME="www.domain.ext"
IF XNAME["^"
QUIT
+3 SET XL1=XNAME
+4 WRITE !!,"Looking up IPv4 address: ",XL1
DO NS(.XLF,XL1,"A",.XL4)
+5 SET XL1="XL4"
FOR
SET XL1=$QUERY(@XL1)
IF XL1=""
QUIT
WRITE !,XL1," = ",@XL1
+6 SET Y=""
FOR
SET Y=$ORDER(XLF("B",Y))
IF Y=""
QUIT
WRITE !,?5,Y," > ",XLF("B",Y)
+7 SET XL1=XNAME
+8 WRITE !!,"Looking up IPv6 address: ",XL1
DO NS(.XLF,XL1,"AAAA",.XL6)
+9 SET XL1="XL6"
FOR
SET XL1=$QUERY(@XL1)
IF XL1=""
QUIT
WRITE !,XL1," = ",@XL1
+10 SET Y=""
FOR
SET Y=$ORDER(XLF("B",Y))
IF Y=""
QUIT
WRITE !,?5,Y," > ",XLF("B",Y)
+11 WRITE !
+12 QUIT
+13 ;
ADDRESS(N,T) ;Get a IP address from a name
+1 NEW XLF,Y,I
SET XLF=""
SET T=$GET(T,"A")
+2 ; change default from "A" to "AAAA" if VistA has IPv6 enabled
IF $$VERSION^XLFIPV
SET T=$GET(T,"AAAA")
+3 IF ^%ZOSF("OS")["OpenM"
IF T="A"
Begin DoDot:1
+4 ; $ZU(54,13,N) is gethostbyname(N) IPv4 address nslookup
XECUTE "S Y=$ZU(54,13,N)"
End DoDot:1
QUIT $PIECE(Y,",")
+5 DO NS(.XLF,N,T)
+6 SET Y=""
FOR I=1:1:XLF("ANCOUNT")
IF $DATA(XLF("AN"_I_"DATA"))
SET Y=Y_XLF("AN"_I_"DATA")_","
+7 QUIT $EXTRACT(Y,1,$LENGTH(Y)-1)
+8 ;
MAIL(RET,N) ;Get the MX address for a domain
+1 ;RET is the return array
+2 NEW XLF,Y,I,T
SET XLF=""
SET T="MX"
+3 DO NS(.XLF,N,T)
+4 SET RET=0
SET I=0
FOR
SET I=$ORDER(XLF("P",I))
IF I'>0
QUIT
Begin DoDot:1
+5 SET N=XLF("P",I)
SET RET(I)=N_"^"_$GET(XLF("B",N))
SET RET=RET+1
End DoDot:1
+6 QUIT
+7 ;
NS(XL,NAME,QTYPE,XLFLOG) ;NAME LOOKUP
+1 ;XL is the return array, NAME is the name to lookup,
+2 ;QTYPE is type of lookup, XLFLOG is a debug array returned.
+3 NEW RI,DNS,CNT,POP
IF '$DATA(XLFLOG)
NEW XLFLOG
SET XL("ANCOUNT")=0
SET CNT=1
+4 DO SAVEDEV
NS2 SET DNS=$$GETDNS(CNT)
IF DNS=""
GOTO EXIT
+1 DO LOG("Call server: "_DNS)
+2 DO CALL^%ZISTCP(DNS,53)
IF POP
SET CNT=CNT+1
GOTO NS2
+3 DO LOG("Got connection, Send message")
+4 ; Uses "A" type for IPv4 if QTYPE is not defined
DO BUILD(NAME,$GET(QTYPE,"A"))
DO LOG("Wait for reply")
+5 ;Close part of READ
+6 DO READ
DO DECODE
+7 DO RESDEV
DO LOG("Returned question: "_$GET(XL("QD1NAME")))
+8 QUIT
EXIT DO RESDEV
+1 QUIT
+2 ;
BUILD(Y,T) ;BUILD A QUERY
+1 ; ID,PARAM,#of?, #ofA, #of Auth, #of add,
+2 NEW X,%,MSG,I
+3 ;Header
SET X=" M"_$CHAR(1,0)_$CHAR(0,1)_$CHAR(0,0)_$CHAR(0,0)_$CHAR(0,0)
+4 ;future fix: implies IPv4 address for DNS server
IF $EXTRACT(Y,$LENGTH(Y))'="."
IF $EXTRACT(Y,$LENGTH(Y))'="."
SET Y=Y_"."
+5 ;Address ;future fix: implies IPv4 address for DNS server
FOR I=1:1:$LENGTH(Y,".")
SET %=$PIECE(Y,".",I)
IF $LENGTH(%)
SET X=X_$CHAR($LENGTH(%))_%
+6 ;End of address ;future fix: implies IPv4 address for DNS server
SET X=X_$CHAR(0)
+7 ;Type A=1, NS=2, CNAME=5, MX=15, AAAA=28 ;p638 Added "AAAA" for IPv6
+8 ;type and class
SET MSG=X_$CHAR(0,$$TYPECODE(T))_$CHAR(0,1)
+9 DO LOG("msg: "_MSG)
+10 USE IO
SET %=$LENGTH(MSG)
WRITE $CHAR(%\256,%#256)_MSG,!
+11 QUIT
READ ;
+1 NEW L1,L2,X,$ETRAP
SET $ETRAP="G RDERR"
KILL RI
SET RI=0
+2 USE IO
READ L1#2:20
IF '$TEST
DO LOG("Time-out")
GOTO RDERR
+3 ;get msg length
SET RI=$ASCII(L1,1)*256+$ASCII(L1,2)
+4 FOR I=1:1:6
READ L2#2:20
IF '$TEST
QUIT
SET XL($PIECE("ID^CODE^QDCOUNT^ANCOUNT^NSCOUNT^ARCOUNT","^",I))=$SELECT(I>2:$$WBN(L2),I=2:$$BIN16(L2),1:L2)
+5 IF '$TEST
DO LOG("Time-out")
GOTO RDERR
+6 DO LOG("Return msg length: "_RI)
+7 ;or use X#1 and $A(X)
FOR I=13:1:RI
USE IO
READ *X:20
IF '$TEST
QUIT
SET RI(I)=X
RDERR ;End of read
+1 DO CLOSE^%ZISTCP
+2 QUIT
DECODE ;
+1 NEW I,IX,X,Y,Z,NN,NN2
IF RI'>7
QUIT
+2 IF $GET(XL("ID"))'=" M"
SET XL("ERR")="Bad Response"
DO LOG(XL("ERR"))
QUIT
+3 ;Decode the header
+4 SET Z=XL("CODE")
SET XL("QR")=$EXTRACT(Z,1)
SET XL("Opcode")=$EXTRACT(Z,2,5)
SET XL("AA")=$EXTRACT(Z,6)
SET XL("TC")=$EXTRACT(Z,7)
SET XL("RD")=$EXTRACT(Z,8)
SET XL("RA")=$EXTRACT(Z,9)
SET XL("RCODE")=$EXTRACT(Z,13,16)
+5 ;The Question section
+6 SET IX=13
+7 FOR NN2=1:1:XL("QDCOUNT")
DO QD("QD"_NN2)
+8 FOR NN="AN","NS","AR"
IF $GET(XL(NN_"COUNT"))
FOR NN2=1:1:XL(NN_"COUNT")
DO RR(NN_NN2)
+9 QUIT
+10 ;
QD(NSP) ;Decode the Question section
+1 NEW Y
+2 SET Y=""
SET IX=IX+$$NAME(IX,.Y,1)
SET XL(NSP_"NAME")=Y
+3 SET XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1))
SET IX=IX+2
+4 SET XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1))
SET IX=IX+2
+5 QUIT
RR(NSP) ;
+1 NEW Y,NA
+2 SET Y=""
SET IX=IX+$$NAME(IX,.Y,1)
SET XL(NSP_"NAME")=Y
SET NA=Y
+3 SET XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1))
SET IX=IX+2
+4 SET XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1))
SET IX=IX+2
+5 SET Y=RI(IX)*256+RI(IX+1)
SET Y=Y*256+RI(IX+2)
SET Y=Y*256+RI(IX+3)
+6 SET XL(NSP_"TTL")=Y
SET IX=IX+4
+7 SET (X,XL(NSP_"LENGTH"))=$$BN(RI(IX),RI(IX+1))
SET IX=IX+2
IF X=0
QUIT
+8 ; IPv4 address
IF XL(NSP_"TYPE")=1
Begin DoDot:1
+9 SET XL(NSP_"DATA")=RI(IX)_"."_RI(IX+1)_"."_RI(IX+2)_"."_RI(IX+3)
SET XL("B",NA)=XL(NSP_"DATA")
End DoDot:1
+10 ; IPv6 address
IF XL(NSP_"TYPE")=28
Begin DoDot:1
+11 SET XL(NSP_"DATA")=$$H1(RI(IX))_$$H1(RI(IX+1))_":"_$$H1(RI(IX+2))_$$H1(RI(IX+3))_":"
+12 SET XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+4))_$$H1(RI(IX+5))_":"_$$H1(RI(IX+6))_$$H1(RI(IX+7))_":"
+13 SET XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+8))_$$H1(RI(IX+9))_":"_$$H1(RI(IX+10))_$$H1(RI(IX+11))_":"
+14 SET XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+12))_$$H1(RI(IX+13))_":"_$$H1(RI(IX+14))_$$H1(RI(IX+15))
+15 SET XL("B",NA)=XL(NSP_"DATA")
End DoDot:1
+16 ; MX entry
IF XL(NSP_"TYPE")=15
DO MX(IX)
+17 SET IX=IX+XL(NSP_"LENGTH")
+18 QUIT
NAME(I,NM,F) ;Decode a NAME section
+1 NEW P,T,Y,X
SET NM=$GET(NM)
IF F
SET T=0
+2 ;Use X as flag to escape recursion.
FOR
SET X=RI(I)
IF (X=0)&F
SET T=T+1
IF X=0
QUIT
Begin DoDot:1
+3 IF (X\64)=3
SET X=$$NAME((X#64)*256+RI(I+1)+1,.NM,0)
SET X=0
IF F
SET T=T+2
QUIT
+4 SET NM=NM_$$PART(I+1,X)
SET I=I+X+1
IF F
SET T=T+X+1
End DoDot:1
IF X=0
QUIT
+5 QUIT $GET(T)
+6 ;
MX(IX) ;Hide IX changes
+1 NEW Y
SET Y=$$BN(RI(IX),RI(IX+1))
+2 FOR
IF '$DATA(XL("P",Y))
QUIT
SET Y=Y+1
+3 SET XL(NSP_"PREF")=Y
SET IX=IX+2
+4 SET Y=""
SET IX=IX+$$NAME(IX,.Y,1)
SET XL(NSP_"NAME")=Y
SET XL("P",XL(NSP_"PREF"))=Y
+5 QUIT
+6 ;
BN(Z1,Z2) ;Convert two binary char 16 bit number into ASCII number
+1 QUIT Z1*256+Z2
+2 ;
WBN(Z1) ;Convert two byte string to a ASCII number
+1 QUIT $ASCII(Z1,1)*256+$ASCII(Z1,2)
+2 ;
H2(Z2) ;Convert 2 byte string to HEX
+1 NEW B
SET B=$ASCII(Z2,1)*256+$ASCII(Z2,2)
+2 QUIT $$H(B)
+3 ;
H1(Z1) ;Convert decimal number <= 256 to two digit HEX number
+1 NEW Y
SET Y=$$CNV^XLFUTL(Z1,16)
+2 QUIT $$RJ^XLFSTR(Y,2,"0")
+3 ;
H(Z1) QUIT $$BASE^XLFUTL(Z1,10,16)
+1 ;
BIN16(S) ;Convert two byte string to 16 bit binary
+1 NEW K,Y
SET S=$ASCII(S,1)*256+$ASCII(S,2)
SET Y=""
+2 FOR K=0:1:15
SET Y=(S\(2**K)#2)_Y
+3 QUIT Y
+4 ;
PART(S,L) ;
+1 NEW R,A
SET R=""
FOR A=S:1:S+L-1
SET R=R_$CHAR(RI(A))
+2 QUIT R_"."
+3 ;
TYPECODE(T) ;
+1 ;1=A:IPv4 address,2=NS:nameserver,5=CNAME,15=MX:mail exchange,28=AAAA:IPv6 address ;p638 Added "AAAA" for IPv6
+2 ;p638 Added "AAAA" for IPv6
IF +T
QUIT $SELECT(T=1:"A",T=2:"NS",T=5:"CNAME",T=15:"MX",T=28:"AAAA",1:"ZZ")
+3 ;p638 Added "AAAA" for IPv6
QUIT $SELECT(T="A":1,T="NS":2,T="CNAME":5,T="MX":15,T="AAAA":28,1:1)
+4 ;
CLASS(T) ;
+1 QUIT $SELECT(T=1:"IN",1:"ZZ")
+2 ;
GETDNS(I) ;Get the address of our DNS
+1 NEW L
SET L=$GET(^XTV(8989.3,1,"DNS"))
+2 QUIT $PIECE(L,",",I)
+3 ;
SHOW ;LIST RI AND XL
+1 SET O1=RI\3+1
SET O2=O1*2
+2 FOR I=1:1:O1
DO SW(0,"RI("_I_")=",$GET(RI(I)))
DO SW(30,"RI("_(I+O1)_")=",$GET(RI(I+O1)))
DO SW(60,"RI("_(I+O2)_")=",$GET(RI(I+O2)))
WRITE !
+3 QUIT
SW(T,H,V) ;
+1 WRITE ?T,$JUSTIFY(H,8),V
+2 QUIT
SAVEDEV ;Save calling device
+1 IF '$DATA(IO(0))
DO HOME^%ZIS
DO SAVDEV^%ZISUTL("XLFNSLK")
+2 QUIT
RESDEV ;Restore calling device
+1 DO USE^%ZISUTL("XLFNSLK")
DO RMDEV^%ZISUTL("XLFNSLK")
+2 KILL IO("CLOSE")
+3 QUIT
LOG(M) ;Log Debug messages
+1 SET XLFLOG=$GET(XLFLOG)+1
SET XLFLOG(XLFLOG)=M
+2 QUIT
+3 ;
POST ;Stuff a DNS address during install POST init.
+1 NEW DIC,DR,DIQ,XLF,DIE
+2 SET XLF=$PIECE($$PARAM^HLCS2,U,3)
+3 IF XLF="T"
DO BMES^XPDUTL("Test Account DNS address not installed.")
QUIT
+4 SET DIC=8989.3
SET DR=51
SET DA=1
SET DIQ="XLF("
DO EN^DIQ1
IF $LENGTH(XLF(8989.3,1,51))
QUIT
+5 SET DR="51///127.0.0.1"
SET DIE="^XTV(8989.3,"
SET DA=1
DO ^DIE
+6 DO BMES^XPDUTL("DNS address installed.")
+7 QUIT
