55 lines
2.4 KiB
Mathematica
55 lines
2.4 KiB
Mathematica
PRCPXODI ;WOIFO/CC-purge On-Demand Audit Activity ; 11/30/06 4:04pm
|
|
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
|
|
;Per VHA Directive 2004-038, this routine should not be modified.
|
|
Q
|
|
; Called from PRCPXALL where STOPDATE and PRCP("I") are set up
|
|
; PRCP("I") is the ien of the inventory point being cleaned
|
|
; STOPDATE is the oldest date for which activity is to be kept
|
|
;
|
|
; NOTE: This program purges the On-Demand Audit records from each
|
|
; item in the inventory point. Although the program is
|
|
; designed to purge any record older than the date indicated
|
|
; in STOPDATE, it is also designed to retain the three most
|
|
; recent audit records, regardless of how old they are.
|
|
;
|
|
DQ N D,DA,DIC,DIK,ITEMDA,PRCPAUDT,PRCPCNT,PRCPSTOP,X
|
|
; loop through for each item
|
|
S ITEMDA=0
|
|
F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:+ITEMDA'>0 D
|
|
. N X,PRCPKEEP
|
|
. I $D(SCAN) W !,"ITEM # ",ITEMDA
|
|
. S X=$O(^PRCP(445,PRCP("I"),1,ITEMDA,10,0)) Q:X="" ; no audits on file
|
|
. S X=$P($G(^PRCP(445,PRCP("I"),1,ITEMDA,10,X,0)),"^",1) ; date of audit
|
|
. I $D(SCAN) W !,"OLDEST AUDIT DATE: ",X
|
|
. I X'<STOPDATE Q ; earliest audit is within retention period
|
|
. ;
|
|
. ; Item has entries that could be purged, save 3 most recent entries
|
|
. S PRCPAUDT="A",PRCPCNT=0,PRCPSTOP=0
|
|
. ; Find 3 oldest entries then proceed to next section
|
|
. F S PRCPAUDT=$O(^PRCP(445,PRCP("I"),1,ITEMDA,10,PRCPAUDT),-1) Q:'+PRCPAUDT D Q:PRCPCNT=3
|
|
. . S PRCPCNT=PRCPCNT+1 I $D(SCAN) W !,"FOUND:",PRCPCNT
|
|
. . I PRCPCNT<4 S PRCPKEEP(PRCPAUDT)=PRCPCNT Q ; keep three most recent audit records
|
|
. . Q
|
|
. ;
|
|
. I PRCPCNT<3 Q ; only 2 records exists and all must be kept
|
|
. ; Loop through all audit records on file, starting with the oldest
|
|
. ; Continue processing until the audit date of a record follows the stop date or processing hits one of the 3 most recent records.
|
|
. S PRCPAUDT=0
|
|
. F S PRCPAUDT=$O(^PRCP(445,PRCP("I"),1,ITEMDA,10,PRCPAUDT)) Q:'+PRCPAUDT D I PRCPSTOP Q
|
|
. . S X=$P($G(^PRCP(445,PRCP("I"),1,ITEMDA,10,PRCPAUDT,0)),"^",1) ; get date of audit record
|
|
. . I $D(SCAN) W !,"AUDIT DATE: ",X," STOPDATE:",STOPDATE
|
|
. . I X'<STOPDATE!$D(PRCPKEEP(PRCPAUDT)) S PRCPSTOP=1 Q ; no more to purge
|
|
. . I $D(SCAN) W !,X," WILL BE PURGED" Q
|
|
. . S DIK="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",10,",DA(1)=ITEMDA,DA(2)=PRCP("I"),DA=PRCPAUDT D ^DIK K DIK,DA
|
|
;
|
|
Q
|
|
;
|
|
TEST ; RUN WITHOUT DELETING AND WITH SCAN ON
|
|
N SCAN
|
|
S SCAN=1
|
|
S STOPDATE=3060625
|
|
;S STOPDATE=3061125
|
|
S PRCP("I")=9
|
|
D DQ
|
|
Q
|