XUSPURGE ;SFISC/STAFF - PURGE ROUTINE FOR XUSEC ; Oct 23, 2023@14:28:20
;;8.0;KERNEL;**180,312,543,756**;Jul 10, 1995;Build 18
;Per VHA Directive 2004-038, this routine should not be modified.
SCPURG ;Purge sign-on log to 365 days
N XUDT,DA,XUNOW,XURETENT
I $O(^XUSEC(0,0))'>0 Q
S XURETENT=$$RETENTION ; get # of days to retain
S XUDT=$$FMADD^XLFDT(DT,-XURETENT),XUNOW=$$NOW^XLFDT() ;Set the limit
F DA=0:0 S DA=$O(^XUSEC(0,DA)) Q:(DA'>0)!('$$EXPIRED(DA,XUDT)) D DELETE(DA,XUNOW)
Q
;
AOLD ;
N DIRUT,DIR,XUT,XUDAYS,XUDT,XUI,XUJ,XUK,X
I $D(ZTQUEUED) D Q
. S X=$G(ZTQPARAM),X=$S(X<270:270,1:X) D A02(X),V02(X)
. Q
W !!,"This option will purge the log of inactive access and verify codes ",!,"older than the date specified to allow for their re-use."
S DIR("A")="Do you wish to continue",DIR(0)="Y",DIR("B")="NO" D ^DIR G:$D(DIRUT)!(Y'=1) ENDA
DAYS K DIR S DIR("A")="How far back do you wish to retain codes",DIR("A",1)="VHA has set the minimum time to keep old codes at 270 days.",DIR("B")=270
S DIR("?")="Enter the number of days indicating at what date codes should be purged.",DIR(0)="N^270:400"
D ^DIR Q:$D(DIRUT)
D A02(X),V02(X)
Q
;
A02(XUDAYS) ;Purge old Access codes in the AOLD x-ref.
N XUT,XUI,XUJ,XUK,XUDT
S XUT=0,XUDT=$H-XUDAYS,XUI=""
F S XUI=$O(^VA(200,"AOLD",XUI)) Q:XUI="" S XUJ=$O(^(XUI,0)) S XUK=^(XUJ) I XUK<XUDT K ^VA(200,"AOLD",XUI,XUJ) S XUT=XUT+1 W:'$D(ZTQUEUED) "."
I '$D(ZTQUEUED) W !!,$S('XUT:"No",1:XUT)," old access codes have been purged."
Q
;
V02(XUDAYS) ;Purge old Verify code from each users VOLD x-ref
N XUT,XUI,XUJ,XUK,XUDT
S XUT=0,XUDT=$H-XUDAYS,XUI=0
F S XUI=$O(^VA(200,XUI)) Q:XUI'>0 S XUK="" D
. F S XUK=$O(^VA(200,XUI,"VOLD",XUK)) Q:XUK="" I ^(XUK)<XUDT K ^VA(200,XUI,"VOLD",XUK) S XUT=XUT+1 W:'$D(ZTQUEUED) "."
I '$D(ZTQUEUED) W !!,$S('XUT:"No",1:XUT)," old verify codes have been purged."
Q
ENDA K DIRUT,DIR,XUT,XUDAYS,XUDT,XUI,XUJ,XUK
Q
;
RETENTION() ; returns number of days to retain SIGN-ON LOG file entries
N XURETENT
S XURETENT=$P(^XTV(8989.3,1,"XUS"),"^",21) ;p756
I ('XURETENT)!($G(XURETENT)<365) S XURETENT=365
I ($G(XURETENT)>9999) S XURETENT=9999
Q XURETENT
;
EXPIRED(XUDA,XUDT) ;Is XUDA older (smaller) than XUDT
Q XUDA<XUDT
;
DELETE(XUDA,XUNOW) ; delete entry XUDA from SIGN-ON LOG file
N DR,XU1,XU2,DIK,DIE
S XU1=$G(^XUSEC(0,XUDA,0)),XU2=+XU1
;Enter a SIGN OFF time to clear the X-ref's p543
I $P(XU1,U,4)="" S DR="3////"_XUNOW,DIE="^XUSEC(0," D ^DIE
;Now kill the record.
S DIK="^XUSEC(0," D ^DIK
;Make sure the CUR X-ref is cleared.
I XU1 K ^XUSEC(0,"CUR",XU2,XUDA)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSPURGE 2644 printed Apr 09, 2024@21:08:56 Page 2
XUSPURGE ;SFISC/STAFF - PURGE ROUTINE FOR XUSEC ; Oct 23, 2023@14:28:20
+1 ;;8.0;KERNEL;**180,312,543,756**;Jul 10, 1995;Build 18
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
SCPURG ;Purge sign-on log to 365 days
+1 NEW XUDT,DA,XUNOW,XURETENT
+2 IF $ORDER(^XUSEC(0,0))'>0
QUIT
+3 ; get # of days to retain
SET XURETENT=$$RETENTION
+4 ;Set the limit
SET XUDT=$$FMADD^XLFDT(DT,-XURETENT)
SET XUNOW=$$NOW^XLFDT()
+5 FOR DA=0:0
SET DA=$ORDER(^XUSEC(0,DA))
if (DA'>0)!('$$EXPIRED(DA,XUDT))
QUIT
DO DELETE(DA,XUNOW)
+6 QUIT
+7 ;
AOLD ;
+1 NEW DIRUT,DIR,XUT,XUDAYS,XUDT,XUI,XUJ,XUK,X
+2 IF $DATA(ZTQUEUED)
Begin DoDot:1
+3 SET X=$GET(ZTQPARAM)
SET X=$SELECT(X<270:270,1:X)
DO A02(X)
DO V02(X)
+4 QUIT
End DoDot:1
QUIT
+5 WRITE !!,"This option will purge the log of inactive access and verify codes ",!,"older than the date specified to allow for their re-use."
+6 SET DIR("A")="Do you wish to continue"
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
if $DATA(DIRUT)!(Y'=1)
GOTO ENDA
DAYS KILL DIR
SET DIR("A")="How far back do you wish to retain codes"
SET DIR("A",1)="VHA has set the minimum time to keep old codes at 270 days."
SET DIR("B")=270
+1 SET DIR("?")="Enter the number of days indicating at what date codes should be purged."
SET DIR(0)="N^270:400"
+2 DO ^DIR
if $DATA(DIRUT)
QUIT
+3 DO A02(X)
DO V02(X)
+4 QUIT
+5 ;
A02(XUDAYS) ;Purge old Access codes in the AOLD x-ref.
+1 NEW XUT,XUI,XUJ,XUK,XUDT
+2 SET XUT=0
SET XUDT=$HOROLOG-XUDAYS
SET XUI=""
+3 FOR
SET XUI=$ORDER(^VA(200,"AOLD",XUI))
if XUI=""
QUIT
SET XUJ=$ORDER(^(XUI,0))
SET XUK=^(XUJ)
IF XUK<XUDT
KILL ^VA(200,"AOLD",XUI,XUJ)
SET XUT=XUT+1
if '$DATA(ZTQUEUED)
WRITE "."
+4 IF '$DATA(ZTQUEUED)
WRITE !!,$SELECT('XUT:"No",1:XUT)," old access codes have been purged."
+5 QUIT
+6 ;
V02(XUDAYS) ;Purge old Verify code from each users VOLD x-ref
+1 NEW XUT,XUI,XUJ,XUK,XUDT
+2 SET XUT=0
SET XUDT=$HOROLOG-XUDAYS
SET XUI=0
+3 FOR
SET XUI=$ORDER(^VA(200,XUI))
if XUI'>0
QUIT
SET XUK=""
Begin DoDot:1
+4 FOR
SET XUK=$ORDER(^VA(200,XUI,"VOLD",XUK))
if XUK=""
QUIT
IF ^(XUK)<XUDT
KILL ^VA(200,XUI,"VOLD",XUK)
SET XUT=XUT+1
if '$DATA(ZTQUEUED)
WRITE "."
End DoDot:1
+5 IF '$DATA(ZTQUEUED)
WRITE !!,$SELECT('XUT:"No",1:XUT)," old verify codes have been purged."
+6 QUIT
ENDA KILL DIRUT,DIR,XUT,XUDAYS,XUDT,XUI,XUJ,XUK
+1 QUIT
+2 ;
RETENTION() ; returns number of days to retain SIGN-ON LOG file entries
+1 NEW XURETENT
+2 ;p756
SET XURETENT=$PIECE(^XTV(8989.3,1,"XUS"),"^",21)
+3 IF ('XURETENT)!($GET(XURETENT)<365)
SET XURETENT=365
+4 IF ($GET(XURETENT)>9999)
SET XURETENT=9999
+5 QUIT XURETENT
+6 ;
EXPIRED(XUDA,XUDT) ;Is XUDA older (smaller) than XUDT
+1 QUIT XUDA<XUDT
+2 ;
DELETE(XUDA,XUNOW) ; delete entry XUDA from SIGN-ON LOG file
+1 NEW DR,XU1,XU2,DIK,DIE
+2 SET XU1=$GET(^XUSEC(0,XUDA,0))
SET XU2=+XU1
+3 ;Enter a SIGN OFF time to clear the X-ref's p543
+4 IF $PIECE(XU1,U,4)=""
SET DR="3////"_XUNOW
SET DIE="^XUSEC(0,"
DO ^DIE
+5 ;Now kill the record.
+6 SET DIK="^XUSEC(0,"
DO ^DIK
+7 ;Make sure the CUR X-ref is cleared.
+8 IF XU1
KILL ^XUSEC(0,"CUR",XU2,XUDA)
+9 QUIT
+10 ;
