HLMA4 ;OIFO-O/RJH-DON'T PING VIE ;03/29/2007 16:21
;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 14
;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
DONTPING(PAR) ;
; check the data stored in file #869.3 related multiples to
; to see if ping is allowed for the Ping option, PING^HLMA
; return 1: don't ping this link.
; return 0: ok to ping the link.
;
N ONE,LINE,PINGOK
S HLQUIET=$G(HLQUIET)
;
; the only one entry in file #869.3
S ONE=$O(^HLCS(869.3,0))
;
D PINGIP
Q:PINGOK 0
;
D DONTPORT
Q:'PINGOK 1
;
D DONTDOMN
Q:'PINGOK 1
;
D DONTNAME
Q:'PINGOK 1
;
D DONTIP
Q:'PINGOK 1
;
D PINGDOMN
Q:PINGOK 0
;
I 'HLQUIET S HLCS="This link is not allowed to ping"
Q 1
;
PINGIP ;
; retrieve the "Ping IP" multiple, which are ok to ping
S PINGOK=0
S LINE=0
F S LINE=$O(^HLCS(869.3,ONE,7,LINE)) Q:'LINE D Q:PINGOK
. N DATAS,COUNT,DATA
. S DATAS=$G(^HLCS(869.3,ONE,7,LINE,0))
. S COUNT=$L(DATAS,",")
. F I=1:1:COUNT D Q:PINGOK
.. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
.. I DATA=HLTCPADD S PINGOK=1
Q
;
DONTPORT ;
; retrieve the "Don't Ping Port" multiple, which are not
; allowed to ping
S PINGOK=1
S LINE=0
F S LINE=$O(^HLCS(869.3,ONE,9,LINE)) Q:'LINE D Q:'PINGOK
. N DATAS,COUNT,DATA
. S DATAS=$G(^HLCS(869.3,ONE,9,LINE,0))
. S COUNT=$L(DATAS,",")
. F I=1:1:COUNT D Q:'PINGOK
.. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
.. I DATA=HLTCPORT D
... S PINGOK=0
... I 'HLQUIET D
.... S HLCS="This link with 'PORT' as '"_HLTCPORT
.... S HLCS=HLCS_"' is not allowed to ping"
Q
;
DONTDOMN ;
; retrieve the "Don't Ping Domain (Full)" multiple,
; which are not allowed to ping
;
N HLDOM
S PINGOK=1
S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
I 'HLDOM,($L(HLDOM("DNS"),".")<3) Q
;
I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
;
S LINE=0
F S LINE=$O(^HLCS(869.3,ONE,12,LINE)) Q:'LINE D Q:'PINGOK
. N DATAS,COUNT,DATA,DNSDOMN,MAILDOMN
. S DATAS=$G(^HLCS(869.3,ONE,12,LINE,0))
. S COUNT=$L(DATAS,",")
. F I=1:1:COUNT D Q:'PINGOK
.. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
.. ; set PINGOK to 0 if domain is not allowed to ping
.. I ($L(HLDOM("DNS"),".")>2),HLDOM("DNS")=DATA D Q
... D SETHLCS(HLDOM("DNS"),"DNS DOMAIN")
.. I $L(HLDOM)>5,HLDOM=DATA D
... D SETHLCS(HLDOM,"MAILMAN DOMAIN")
Q
;
SETHLCS(DATA,TYPE) ;
; to be called from sub-routine DONTDOMN
S PINGOK=0
I 'HLQUIET D
. S HLCS="This link with '"_TYPE_"' as '"_DATA
. S HLCS=HLCS_"' is not allowed to ping"
Q
;
DONTNAME ;
; retrieve the "Don't Ping Link Name (Partial)" multiple,
; which are not allowed to ping
;
N LINKNAME
S PINGOK=1
;
S LINKNAME=$P(^HLCS(870,HLDP,0),U,1)
;
S LINE=0
F S LINE=$O(^HLCS(869.3,ONE,10,LINE)) Q:'LINE D Q:'PINGOK
. N DATAS,COUNT,DATA
. S DATAS=$G(^HLCS(869.3,ONE,10,LINE,0))
. S COUNT=$L(DATAS,",")
. F I=1:1:COUNT D Q:'PINGOK
.. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
.. I LINKNAME[DATA D
... S PINGOK=0
... I 'HLQUIET D
.... S HLCS="This link 'NAME' containing name-stub"
.... S HLCS=HLCS_" '"_DATA_"' is not allowed to ping"
Q
;
DONTIP ;
; retrieve the "Don't Ping IP" multiple, which are not
; allowed to ping
;
S PINGOK=1
;
S LINE=0
F S LINE=$O(^HLCS(869.3,ONE,11,LINE)) Q:'LINE D Q:'PINGOK
. N DATAS,COUNT,DATA
. S DATAS=$G(^HLCS(869.3,ONE,11,LINE,0))
. S COUNT=$L(DATAS,",")
. F I=1:1:COUNT D Q:'PINGOK
.. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
.. I DATA=HLTCPADD D
... S PINGOK=0
... I 'HLQUIET D
.... S HLCS="This link with 'IP' as '"_HLTCPADD
.... S HLCS=HLCS_"' is not allowed to ping"
Q
;
PINGDOMN ;
; retrieve the "Ping Domain (Partial)" multiple,
; which is ok to ping, data could be partial domain.
;
N HLDOM
S PINGOK=0
;
S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
I 'HLDOM,($L(HLDOM("DNS"),".")<3) Q
;
I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
;
S LINE=0
F S LINE=$O(^HLCS(869.3,ONE,8,LINE)) Q:'LINE D Q:PINGOK
. N DATAS,COUNT,DATA,DNSDOMN,MAILDOMN
. S DATAS=$G(^HLCS(869.3,ONE,8,LINE,0))
. S COUNT=$L(DATAS,",")
. F I=1:1:COUNT D Q:PINGOK
.. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
.. ; set PINGOK to 1 if domain is allowed to ping
.. I ($L(HLDOM("DNS"),".")>2),HLDOM("DNS")[DATA S PINGOK=1 Q
.. I $L(HLDOM)>5,HLDOM[DATA S PINGOK=1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLMA4 4514 printed Sep 23, 2025@19:34:26 Page 2
HLMA4 ;OIFO-O/RJH-DON'T PING VIE ;03/29/2007 16:21
+1 ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 14
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
DONTPING(PAR) ;
+1 ; check the data stored in file #869.3 related multiples to
+2 ; to see if ping is allowed for the Ping option, PING^HLMA
+3 ; return 1: don't ping this link.
+4 ; return 0: ok to ping the link.
+5 ;
+6 NEW ONE,LINE,PINGOK
+7 SET HLQUIET=$GET(HLQUIET)
+8 ;
+9 ; the only one entry in file #869.3
+10 SET ONE=$ORDER(^HLCS(869.3,0))
+11 ;
+12 DO PINGIP
+13 if PINGOK
QUIT 0
+14 ;
+15 DO DONTPORT
+16 if 'PINGOK
QUIT 1
+17 ;
+18 DO DONTDOMN
+19 if 'PINGOK
QUIT 1
+20 ;
+21 DO DONTNAME
+22 if 'PINGOK
QUIT 1
+23 ;
+24 DO DONTIP
+25 if 'PINGOK
QUIT 1
+26 ;
+27 DO PINGDOMN
+28 if PINGOK
QUIT 0
+29 ;
+30 IF 'HLQUIET
SET HLCS="This link is not allowed to ping"
+31 QUIT 1
+32 ;
PINGIP ;
+1 ; retrieve the "Ping IP" multiple, which are ok to ping
+2 SET PINGOK=0
+3 SET LINE=0
+4 FOR
SET LINE=$ORDER(^HLCS(869.3,ONE,7,LINE))
if 'LINE
QUIT
Begin DoDot:1
+5 NEW DATAS,COUNT,DATA
+6 SET DATAS=$GET(^HLCS(869.3,ONE,7,LINE,0))
+7 SET COUNT=$LENGTH(DATAS,",")
+8 FOR I=1:1:COUNT
Begin DoDot:2
+9 SET DATA=$PIECE(DATAS,",",I)
SET DATA=$TRANSLATE(DATA," ","")
+10 IF DATA=HLTCPADD
SET PINGOK=1
End DoDot:2
if PINGOK
QUIT
End DoDot:1
if PINGOK
QUIT
+11 QUIT
+12 ;
DONTPORT ;
+1 ; retrieve the "Don't Ping Port" multiple, which are not
+2 ; allowed to ping
+3 SET PINGOK=1
+4 SET LINE=0
+5 FOR
SET LINE=$ORDER(^HLCS(869.3,ONE,9,LINE))
if 'LINE
QUIT
Begin DoDot:1
+6 NEW DATAS,COUNT,DATA
+7 SET DATAS=$GET(^HLCS(869.3,ONE,9,LINE,0))
+8 SET COUNT=$LENGTH(DATAS,",")
+9 FOR I=1:1:COUNT
Begin DoDot:2
+10 SET DATA=$PIECE(DATAS,",",I)
SET DATA=$TRANSLATE(DATA," ","")
+11 IF DATA=HLTCPORT
Begin DoDot:3
+12 SET PINGOK=0
+13 IF 'HLQUIET
Begin DoDot:4
+14 SET HLCS="This link with 'PORT' as '"_HLTCPORT
+15 SET HLCS=HLCS_"' is not allowed to ping"
End DoDot:4
End DoDot:3
End DoDot:2
if 'PINGOK
QUIT
End DoDot:1
if 'PINGOK
QUIT
+16 QUIT
+17 ;
DONTDOMN ;
+1 ; retrieve the "Don't Ping Domain (Full)" multiple,
+2 ; which are not allowed to ping
+3 ;
+4 NEW HLDOM
+5 SET PINGOK=1
+6 SET HLDOM=$PIECE(^HLCS(870,HLDP,0),U,7)
+7 SET HLDOM("DNS")=$PIECE($GET(^HLCS(870,+$GET(HLDP),0)),"^",8)
+8 IF 'HLDOM
IF ($LENGTH(HLDOM("DNS"),".")<3)
QUIT
+9 ;
+10 IF HLDOM
SET HLDOM=$PIECE(^DIC(4.2,HLDOM,0),U)
+11 ;
+12 SET LINE=0
+13 FOR
SET LINE=$ORDER(^HLCS(869.3,ONE,12,LINE))
if 'LINE
QUIT
Begin DoDot:1
+14 NEW DATAS,COUNT,DATA,DNSDOMN,MAILDOMN
+15 SET DATAS=$GET(^HLCS(869.3,ONE,12,LINE,0))
+16 SET COUNT=$LENGTH(DATAS,",")
+17 FOR I=1:1:COUNT
Begin DoDot:2
+18 SET DATA=$PIECE(DATAS,",",I)
SET DATA=$TRANSLATE(DATA," ","")
+19 ; set PINGOK to 0 if domain is not allowed to ping
+20 IF ($LENGTH(HLDOM("DNS"),".")>2)
IF HLDOM("DNS")=DATA
Begin DoDot:3
+21 DO SETHLCS(HLDOM("DNS"),"DNS DOMAIN")
End DoDot:3
QUIT
+22 IF $LENGTH(HLDOM)>5
IF HLDOM=DATA
Begin DoDot:3
+23 DO SETHLCS(HLDOM,"MAILMAN DOMAIN")
End DoDot:3
End DoDot:2
if 'PINGOK
QUIT
End DoDot:1
if 'PINGOK
QUIT
+24 QUIT
+25 ;
SETHLCS(DATA,TYPE) ;
+1 ; to be called from sub-routine DONTDOMN
+2 SET PINGOK=0
+3 IF 'HLQUIET
Begin DoDot:1
+4 SET HLCS="This link with '"_TYPE_"' as '"_DATA
+5 SET HLCS=HLCS_"' is not allowed to ping"
End DoDot:1
+6 QUIT
+7 ;
DONTNAME ;
+1 ; retrieve the "Don't Ping Link Name (Partial)" multiple,
+2 ; which are not allowed to ping
+3 ;
+4 NEW LINKNAME
+5 SET PINGOK=1
+6 ;
+7 SET LINKNAME=$PIECE(^HLCS(870,HLDP,0),U,1)
+8 ;
+9 SET LINE=0
+10 FOR
SET LINE=$ORDER(^HLCS(869.3,ONE,10,LINE))
if 'LINE
QUIT
Begin DoDot:1
+11 NEW DATAS,COUNT,DATA
+12 SET DATAS=$GET(^HLCS(869.3,ONE,10,LINE,0))
+13 SET COUNT=$LENGTH(DATAS,",")
+14 FOR I=1:1:COUNT
Begin DoDot:2
+15 SET DATA=$PIECE(DATAS,",",I)
SET DATA=$TRANSLATE(DATA," ","")
+16 IF LINKNAME[DATA
Begin DoDot:3
+17 SET PINGOK=0
+18 IF 'HLQUIET
Begin DoDot:4
+19 SET HLCS="This link 'NAME' containing name-stub"
+20 SET HLCS=HLCS_" '"_DATA_"' is not allowed to ping"
End DoDot:4
End DoDot:3
End DoDot:2
if 'PINGOK
QUIT
End DoDot:1
if 'PINGOK
QUIT
+21 QUIT
+22 ;
DONTIP ;
+1 ; retrieve the "Don't Ping IP" multiple, which are not
+2 ; allowed to ping
+3 ;
+4 SET PINGOK=1
+5 ;
+6 SET LINE=0
+7 FOR
SET LINE=$ORDER(^HLCS(869.3,ONE,11,LINE))
if 'LINE
QUIT
Begin DoDot:1
+8 NEW DATAS,COUNT,DATA
+9 SET DATAS=$GET(^HLCS(869.3,ONE,11,LINE,0))
+10 SET COUNT=$LENGTH(DATAS,",")
+11 FOR I=1:1:COUNT
Begin DoDot:2
+12 SET DATA=$PIECE(DATAS,",",I)
SET DATA=$TRANSLATE(DATA," ","")
+13 IF DATA=HLTCPADD
Begin DoDot:3
+14 SET PINGOK=0
+15 IF 'HLQUIET
Begin DoDot:4
+16 SET HLCS="This link with 'IP' as '"_HLTCPADD
+17 SET HLCS=HLCS_"' is not allowed to ping"
End DoDot:4
End DoDot:3
End DoDot:2
if 'PINGOK
QUIT
End DoDot:1
if 'PINGOK
QUIT
+18 QUIT
+19 ;
PINGDOMN ;
+1 ; retrieve the "Ping Domain (Partial)" multiple,
+2 ; which is ok to ping, data could be partial domain.
+3 ;
+4 NEW HLDOM
+5 SET PINGOK=0
+6 ;
+7 SET HLDOM=$PIECE(^HLCS(870,HLDP,0),U,7)
+8 SET HLDOM("DNS")=$PIECE($GET(^HLCS(870,+$GET(HLDP),0)),"^",8)
+9 IF 'HLDOM
IF ($LENGTH(HLDOM("DNS"),".")<3)
QUIT
+10 ;
+11 IF HLDOM
SET HLDOM=$PIECE(^DIC(4.2,HLDOM,0),U)
+12 ;
+13 SET LINE=0
+14 FOR
SET LINE=$ORDER(^HLCS(869.3,ONE,8,LINE))
if 'LINE
QUIT
Begin DoDot:1
+15 NEW DATAS,COUNT,DATA,DNSDOMN,MAILDOMN
+16 SET DATAS=$GET(^HLCS(869.3,ONE,8,LINE,0))
+17 SET COUNT=$LENGTH(DATAS,",")
+18 FOR I=1:1:COUNT
Begin DoDot:2
+19 SET DATA=$PIECE(DATAS,",",I)
SET DATA=$TRANSLATE(DATA," ","")
+20 ; set PINGOK to 1 if domain is allowed to ping
+21 IF ($LENGTH(HLDOM("DNS"),".")>2)
IF HLDOM("DNS")[DATA
SET PINGOK=1
QUIT
+22 IF $LENGTH(HLDOM)>5
IF HLDOM[DATA
SET PINGOK=1
End DoDot:2
if PINGOK
QUIT
End DoDot:1
if PINGOK
QUIT
+23 QUIT
+24 ;
