| [613] | 1 | PRCPXODI ;WOIFO/CC-purge On-Demand Audit Activity ; 11/30/06 4:04pm
|
|---|
| 2 | ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
|
|---|
| 3 | ;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ; Called from PRCPXALL where STOPDATE and PRCP("I") are set up
|
|---|
| 6 | ; PRCP("I") is the ien of the inventory point being cleaned
|
|---|
| 7 | ; STOPDATE is the oldest date for which activity is to be kept
|
|---|
| 8 | ;
|
|---|
| 9 | ; NOTE: This program purges the On-Demand Audit records from each
|
|---|
| 10 | ; item in the inventory point. Although the program is
|
|---|
| 11 | ; designed to purge any record older than the date indicated
|
|---|
| 12 | ; in STOPDATE, it is also designed to retain the three most
|
|---|
| 13 | ; recent audit records, regardless of how old they are.
|
|---|
| 14 | ;
|
|---|
| 15 | DQ N D,DA,DIC,DIK,ITEMDA,PRCPAUDT,PRCPCNT,PRCPSTOP,X
|
|---|
| 16 | ; loop through for each item
|
|---|
| 17 | S ITEMDA=0
|
|---|
| 18 | F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:+ITEMDA'>0 D
|
|---|
| 19 | . N X,PRCPKEEP
|
|---|
| 20 | . I $D(SCAN) W !,"ITEM # ",ITEMDA
|
|---|
| 21 | . S X=$O(^PRCP(445,PRCP("I"),1,ITEMDA,10,0)) Q:X="" ; no audits on file
|
|---|
| 22 | . S X=$P($G(^PRCP(445,PRCP("I"),1,ITEMDA,10,X,0)),"^",1) ; date of audit
|
|---|
| 23 | . I $D(SCAN) W !,"OLDEST AUDIT DATE: ",X
|
|---|
| 24 | . I X'<STOPDATE Q ; earliest audit is within retention period
|
|---|
| 25 | . ;
|
|---|
| 26 | . ; Item has entries that could be purged, save 3 most recent entries
|
|---|
| 27 | . S PRCPAUDT="A",PRCPCNT=0,PRCPSTOP=0
|
|---|
| 28 | . ; Find 3 oldest entries then proceed to next section
|
|---|
| 29 | . F S PRCPAUDT=$O(^PRCP(445,PRCP("I"),1,ITEMDA,10,PRCPAUDT),-1) Q:'+PRCPAUDT D Q:PRCPCNT=3
|
|---|
| 30 | . . S PRCPCNT=PRCPCNT+1 I $D(SCAN) W !,"FOUND:",PRCPCNT
|
|---|
| 31 | . . I PRCPCNT<4 S PRCPKEEP(PRCPAUDT)=PRCPCNT Q ; keep three most recent audit records
|
|---|
| 32 | . . Q
|
|---|
| 33 | . ;
|
|---|
| 34 | . I PRCPCNT<3 Q ; only 2 records exists and all must be kept
|
|---|
| 35 | . ; Loop through all audit records on file, starting with the oldest
|
|---|
| 36 | . ; Continue processing until the audit date of a record follows the stop date or processing hits one of the 3 most recent records.
|
|---|
| 37 | . S PRCPAUDT=0
|
|---|
| 38 | . F S PRCPAUDT=$O(^PRCP(445,PRCP("I"),1,ITEMDA,10,PRCPAUDT)) Q:'+PRCPAUDT D I PRCPSTOP Q
|
|---|
| 39 | . . S X=$P($G(^PRCP(445,PRCP("I"),1,ITEMDA,10,PRCPAUDT,0)),"^",1) ; get date of audit record
|
|---|
| 40 | . . I $D(SCAN) W !,"AUDIT DATE: ",X," STOPDATE:",STOPDATE
|
|---|
| 41 | . . I X'<STOPDATE!$D(PRCPKEEP(PRCPAUDT)) S PRCPSTOP=1 Q ; no more to purge
|
|---|
| 42 | . . I $D(SCAN) W !,X," WILL BE PURGED" Q
|
|---|
| 43 | . . S DIK="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",10,",DA(1)=ITEMDA,DA(2)=PRCP("I"),DA=PRCPAUDT D ^DIK K DIK,DA
|
|---|
| 44 | ;
|
|---|
| 45 | Q
|
|---|
| 46 | ;
|
|---|
| 47 | TEST ; RUN WITHOUT DELETING AND WITH SCAN ON
|
|---|
| 48 | N SCAN
|
|---|
| 49 | S SCAN=1
|
|---|
| 50 | S STOPDATE=3060625
|
|---|
| 51 | ;S STOPDATE=3061125
|
|---|
| 52 | S PRCP("I")=9
|
|---|
| 53 | D DQ
|
|---|
| 54 | Q
|
|---|
