source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPXODI.m@ 1078

Last change on this file since 1078 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1PRCPXODI ;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 ;
15DQ 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 ;
47TEST ; 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
Note: See TracBrowser for help on using the repository browser.