172 lines
4.2 KiB
Mathematica
172 lines
4.2 KiB
Mathematica
|
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
|
||
|
|
;
|