XUSFACHK ;ISF/RWF - FAILED ACCESS ATTEMPTS LOG MONITOR ;10/15/2003 15:25
;;8.0;KERNEL;**265**;July 10, 1995
Q
;Built on work by DAF.
FAILED ;FAILED ACCESS ATTEMPTS SCAN PROGRAM
;This subroutine will watch over file 3.05 and report if it
;finds repeated signon attempts from the same IP address
N DA,DIC,DIE,DIK,DR,%,%Y,ZCNT,WORK,XKT,TCI
N XLST,LAST,TCNT,NUM,NOW,ZTIO,AODLM,AODBUL,IRMLM,IRMBUL
K ^TMP($J)
S NOW=$$NOW^XLFDT,^XTMP("XUSFACHK",0)=$$HTFM^XLFDT($H+3)
;Check last time this ran. reset last run time to now.
S XLST=$$GET1^DIQ(8989.3,"1,",405.15,"I"),DA=1,DIE="^XTV(8989.3,",DR="405.15////"_NOW D ^DIE
S XKT=$$GET1^DIQ(8989.3,"1,",405.17,"I") ;Get Keep Threshold
S TCI=$$GET1^DIQ(8989.3,"1,",405.18,"I") ;Get Total Count Increase
;loop through failed attempts log. count any that happened since last run time.
S NUM=XLST-.0000001 S:NUM<0 NUM=0
F S NUM=$O(^%ZUA(3.05,NUM)) Q:NUM'>0 D
. S ZTIO=$P(^%ZUA(3.05,NUM,0),"^",7) Q:'$L(ZTIO) S ZTIO=$P(ZTIO,$S(ZTIO["/":"/",1:":"),1)
. S ^TMP($J,ZTIO)=$G(^TMP($J,ZTIO))+1
CHKIT ;check to see if number of attempts on any one port is over KEEP THRESHOLD, if so save it.
S IRMLM=$$GET1^DIQ(8989.3,"1,",405.12,"I"),AODLM=$$GET1^DIQ(8989.3,"1,",405.13,"I"),WORK=$$NBH(NOW)
S (AODBUL,IRMBUL,TCNT)=0
S ZTIO="" F S ZTIO=$O(^TMP($J,ZTIO)) Q:'$L(ZTIO) D
. S TCNT=TCNT+^TMP($J,ZTIO)
. D:^TMP($J,ZTIO)>XKT SET
. I WORK,($G(^XTMP("XUSFACHK",2,ZTIO))>IRMLM)!(TCNT>(IRMLM+TCI)) S IRMBUL=1
. I 'WORK,($G(^XTMP("XUSFACHK",2,ZTIO))>AODLM)!(TCNT>(AODLM+TCI)) S AODBUL=1
. Q
D CLEAN
;send bulletin to irm if during work hours. if after hours send to irm and aod.
I IRMBUL!(AODBUL) D BULL
EXIT Q
;clean up and leave.
CLEAN ;clean up ^XTMP("XUSFACHK" global, If no new failed attempts remove.
N ZNUM,ZZNUM
S ZNUM="" F S ZNUM=$O(^XTMP("XUSFACHK",2,ZNUM)) Q:'$L(ZNUM) D
.I '$D(^TMP($J,ZNUM)) D
..K ^XTMP("XUSFACHK",2,ZNUM)
Q
SET ;set ^XTMP("XUSFACHK" global.
S ^XTMP("XUSFACHK",2,ZTIO)=$G(^XTMP("XUSFACHK",2,ZTIO))+^TMP($J,ZTIO)
Q
BULL ;send bulletin to irm. if after hours, send to aod and have irm paged.
N NUM,DTE,X,Y,XMY,XMSUB,XMTEXT,ZCNT,I,XMDUZ,XMZ
S XMSUB="THERE HAVE BEEN A LARGE NUMBER OF FAILED ACCESS ATTEMPTS!!"
S XMTEXT="^TMP(""XM"",$J,",XMDUZ=.5,ZCNT=0
S Y=$$GET1^DIQ(8989.3,"1,",.02,"I") I $L(Y) S XMY(Y)=""
I AODBUL S Y=$$GET1^DIQ(8989.3,"1,",.03,"I") I $L(Y) S XMY(Y)=""
I '$D(XMY) S XMY(.5)=""
S DTE=$$FMTE^XLFDT(XLST,"1P")
D TXT("Since "_DTE_" there have been "_TCNT_" failed access attempts on VistA")
S NUM="" F S NUM=$O(^TMP($J,NUM)) Q:NUM']"" I ^TMP($J,NUM)>XKT D
. D TXT("Device "_NUM_" has had "_$G(^XTMP("XUSFACHK",2,NUM))_" attempts total so far.")
. Q
D TXT(" ")
D TXT("Someone from IRM should check the Failed Access Attempts log.")
I AODBUL D TXT("AOD PLEASE PAGE THE IRM ON-CALL PERSON")
N DO,DIX,DIY
D ^XMD
Q
;
TXT(S) ;Add text to ^TMP("XM",$J
S ZCNT=ZCNT+1,^TMP("XM",$J,ZCNT)=S
Q
;
NBH(DATE) ;FIND OUT IF NOW IS DURING NORMAL BUSINESS HOURS.
;SEND DATE/TIME IN FILEMAN FORMAT
N %,%Y
S %Y=$$DOW^XLFDT(DATE,1)
Q:%Y<1!(%Y>5) 0
Q:$D(^HOLIDAY($P(DATE,".",1))) 0
Q:$E($P(DATE,".",2)_"0000",1,4)>1630!($E($P(DATE,".",2)_"0000",1,4)<0800) 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSFACHK 3246 printed Sep 23, 2025@19:48:44 Page 2
XUSFACHK ;ISF/RWF - FAILED ACCESS ATTEMPTS LOG MONITOR ;10/15/2003 15:25
+1 ;;8.0;KERNEL;**265**;July 10, 1995
+2 QUIT
+3 ;Built on work by DAF.
FAILED ;FAILED ACCESS ATTEMPTS SCAN PROGRAM
+1 ;This subroutine will watch over file 3.05 and report if it
+2 ;finds repeated signon attempts from the same IP address
+3 NEW DA,DIC,DIE,DIK,DR,%,%Y,ZCNT,WORK,XKT,TCI
+4 NEW XLST,LAST,TCNT,NUM,NOW,ZTIO,AODLM,AODBUL,IRMLM,IRMBUL
+5 KILL ^TMP($JOB)
+6 SET NOW=$$NOW^XLFDT
SET ^XTMP("XUSFACHK",0)=$$HTFM^XLFDT($HOROLOG+3)
+7 ;Check last time this ran. reset last run time to now.
+8 SET XLST=$$GET1^DIQ(8989.3,"1,",405.15,"I")
SET DA=1
SET DIE="^XTV(8989.3,"
SET DR="405.15////"_NOW
DO ^DIE
+9 ;Get Keep Threshold
SET XKT=$$GET1^DIQ(8989.3,"1,",405.17,"I")
+10 ;Get Total Count Increase
SET TCI=$$GET1^DIQ(8989.3,"1,",405.18,"I")
+11 ;loop through failed attempts log. count any that happened since last run time.
+12 SET NUM=XLST-.0000001
if NUM<0
SET NUM=0
+13 FOR
SET NUM=$ORDER(^%ZUA(3.05,NUM))
if NUM'>0
QUIT
Begin DoDot:1
+14 SET ZTIO=$PIECE(^%ZUA(3.05,NUM,0),"^",7)
if '$LENGTH(ZTIO)
QUIT
SET ZTIO=$PIECE(ZTIO,$SELECT(ZTIO["/":"/",1:":"),1)
+15 SET ^TMP($JOB,ZTIO)=$GET(^TMP($JOB,ZTIO))+1
End DoDot:1
CHKIT ;check to see if number of attempts on any one port is over KEEP THRESHOLD, if so save it.
+1 SET IRMLM=$$GET1^DIQ(8989.3,"1,",405.12,"I")
SET AODLM=$$GET1^DIQ(8989.3,"1,",405.13,"I")
SET WORK=$$NBH(NOW)
+2 SET (AODBUL,IRMBUL,TCNT)=0
+3 SET ZTIO=""
FOR
SET ZTIO=$ORDER(^TMP($JOB,ZTIO))
if '$LENGTH(ZTIO)
QUIT
Begin DoDot:1
+4 SET TCNT=TCNT+^TMP($JOB,ZTIO)
+5 if ^TMP($JOB,ZTIO)>XKT
DO SET
+6 IF WORK
IF ($GET(^XTMP("XUSFACHK",2,ZTIO))>IRMLM)!(TCNT>(IRMLM+TCI))
SET IRMBUL=1
+7 IF 'WORK
IF ($GET(^XTMP("XUSFACHK",2,ZTIO))>AODLM)!(TCNT>(AODLM+TCI))
SET AODBUL=1
+8 QUIT
End DoDot:1
+9 DO CLEAN
+10 ;send bulletin to irm if during work hours. if after hours send to irm and aod.
+11 IF IRMBUL!(AODBUL)
DO BULL
EXIT QUIT
+1 ;clean up and leave.
CLEAN ;clean up ^XTMP("XUSFACHK" global, If no new failed attempts remove.
+1 NEW ZNUM,ZZNUM
+2 SET ZNUM=""
FOR
SET ZNUM=$ORDER(^XTMP("XUSFACHK",2,ZNUM))
if '$LENGTH(ZNUM)
QUIT
Begin DoDot:1
+3 IF '$DATA(^TMP($JOB,ZNUM))
Begin DoDot:2
+4 KILL ^XTMP("XUSFACHK",2,ZNUM)
End DoDot:2
End DoDot:1
+5 QUIT
SET ;set ^XTMP("XUSFACHK" global.
+1 SET ^XTMP("XUSFACHK",2,ZTIO)=$GET(^XTMP("XUSFACHK",2,ZTIO))+^TMP($JOB,ZTIO)
+2 QUIT
BULL ;send bulletin to irm. if after hours, send to aod and have irm paged.
+1 NEW NUM,DTE,X,Y,XMY,XMSUB,XMTEXT,ZCNT,I,XMDUZ,XMZ
+2 SET XMSUB="THERE HAVE BEEN A LARGE NUMBER OF FAILED ACCESS ATTEMPTS!!"
+3 SET XMTEXT="^TMP(""XM"",$J,"
SET XMDUZ=.5
SET ZCNT=0
+4 SET Y=$$GET1^DIQ(8989.3,"1,",.02,"I")
IF $LENGTH(Y)
SET XMY(Y)=""
+5 IF AODBUL
SET Y=$$GET1^DIQ(8989.3,"1,",.03,"I")
IF $LENGTH(Y)
SET XMY(Y)=""
+6 IF '$DATA(XMY)
SET XMY(.5)=""
+7 SET DTE=$$FMTE^XLFDT(XLST,"1P")
+8 DO TXT("Since "_DTE_" there have been "_TCNT_" failed access attempts on VistA")
+9 SET NUM=""
FOR
SET NUM=$ORDER(^TMP($JOB,NUM))
if NUM']""
QUIT
IF ^TMP($JOB,NUM)>XKT
Begin DoDot:1
+10 DO TXT("Device "_NUM_" has had "_$GET(^XTMP("XUSFACHK",2,NUM))_" attempts total so far.")
+11 QUIT
End DoDot:1
+12 DO TXT(" ")
+13 DO TXT("Someone from IRM should check the Failed Access Attempts log.")
+14 IF AODBUL
DO TXT("AOD PLEASE PAGE THE IRM ON-CALL PERSON")
+15 NEW DO,DIX,DIY
+16 DO ^XMD
+17 QUIT
+18 ;
TXT(S) ;Add text to ^TMP("XM",$J
+1 SET ZCNT=ZCNT+1
SET ^TMP("XM",$JOB,ZCNT)=S
+2 QUIT
+3 ;
NBH(DATE) ;FIND OUT IF NOW IS DURING NORMAL BUSINESS HOURS.
+1 ;SEND DATE/TIME IN FILEMAN FORMAT
+2 NEW %,%Y
+3 SET %Y=$$DOW^XLFDT(DATE,1)
+4 if %Y<1!(%Y>5)
QUIT 0
+5 if $DATA(^HOLIDAY($PIECE(DATE,".",1)))
QUIT 0
+6 if $EXTRACT($PIECE(DATE,".",2)_"0000",1,4)>1630!($EXTRACT($PIECE(DATE,".",2)_"0000",1,4)<0800)
QUIT 0
+7 QUIT 1
