XUSPURGE ;SFISC/STAFF - PURGE ROUTINE FOR XUSEC ;03/18/10 07:10
;;8.0;KERNEL;**180,312,543**;Jul 10, 1995;Build 18
;Per VHA Directive 2004-038, this routine should not be modified.
SCPURG ;Purge sign-on log to 30 days
N XU1,XU2,XUDT,DIK,DA,DIE,DR,XUNOW
S XUDT=$$FMADD^XLFDT(DT,-30),XUNOW=$$NOW^XLFDT() ;Set the limit
I $O(^XUSEC(0,0))'>0 Q
F DA=0:0 S DA=$O(^XUSEC(0,DA)) Q:(DA'>0)!(DA>XUDT) D
. S XU1=$G(^XUSEC(0,DA,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,DA)
. Q
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
XUSPURGE ;SFISC/STAFF - PURGE ROUTINE FOR XUSEC ;03/18/10 07:10
+1 ;;8.0;KERNEL;**180,312,543**;Jul 10, 1995;Build 18
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
SCPURG ;Purge sign-on log to 30 days
+1 NEW XU1,XU2,XUDT,DIK,DA,DIE,DR,XUNOW
+2 ;Set the limit
SET XUDT=$$FMADD^XLFDT(DT,-30)
SET XUNOW=$$NOW^XLFDT()
+3 IF $ORDER(^XUSEC(0,0))'>0
QUIT
+4 FOR DA=0:0
SET DA=$ORDER(^XUSEC(0,DA))
IF (DA'>0)!(DA>XUDT)
QUIT
Begin DoDot:1
+5 SET XU1=$GET(^XUSEC(0,DA,0))
SET XU2=+XU1
+6 ;Enter a SIGN OFF time to clear the X-ref's p543
+7 IF $PIECE(XU1,U,4)=""
SET DR="3////"_XUNOW
SET DIE="^XUSEC(0,"
DO ^DIE
+8 ;Now kill the record.
+9 SET DIK="^XUSEC(0,"
DO ^DIK
+10 ;Make sure the CUR X-ref is cleared.
+11 IF XU1
KILL ^XUSEC(0,"CUR",XU2,DA)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
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
