View source for Purge Old ACCESS/VERIFY Codes

This code snippet is intended to replace the routine call AOLD^XUSPURGE in Menu Option XUSERAOLD. Checks for Production system, and uses new code only if system is Testing.

This allows clearing all codes if desired, Option XUSERAOLD can also be scheduled in Taskman if desired.

 AOLD   ;; check whether Production or Testing
        If $$PROD^XUPROD DO AOLD^XUSPURGE QUIT  ;; If this is a production system, Keep the legacy 270 day minimum.
        ;
        N DIRUT,DIR,XUT,XUDAYS,XUDT,XUI,XUJ,XUK,X
        I $D(ZTQUEUED) D  Q
        . S X=$G(ZTQPARAM)-1 D A02^XUSPURGE(X),V02^XUSPURGE(X)
        . Q                ;; Option can be scheduled with number of days in Parameter field
        W !!,"This option will purge the log of inactive access and verify codes ",!
        W "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
        I $D(DIRUT)!(Y'=1) K DIRUT,DIR,XUT,XUDAYS,XUDT,XUI,XUJ,XUK Quit
        S DIR("?")="Enter a number of days indicating what date codes should be purged."
        S DIR("A",1)="   VHA has set the minimum time to keep old codes at 270 days."
        S DIR("A",2)="   But this not the VA..."
        S DIR("A",3)="   And this is not a Production System."
        S DIR("A")="So how many days back do you wish to retain codes?"
        S DIR("B")=30      ;; default; was 270
        S DIR(0)="N^0:400" ;; allowed range; was 270:400
        D ^DIR Q:$D(DIRUT)
        S X=X-1            ;; X=0 will leave Today.
        D A02^XUSPURGE(X),V02^XUSPURGE(X)
        Q