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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPXODI 2545 printed Sep 23, 2025@19:52:57 Page 2
PRCPXODI ;WOIFO/CC-purge On-Demand Audit Activity ; 11/30/06 4:04pm
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ; Called from PRCPXALL where STOPDATE and PRCP("I") are set up
+5 ; PRCP("I") is the ien of the inventory point being cleaned
+6 ; STOPDATE is the oldest date for which activity is to be kept
+7 ;
+8 ; NOTE: This program purges the On-Demand Audit records from each
+9 ; item in the inventory point. Although the program is
+10 ; designed to purge any record older than the date indicated
+11 ; in STOPDATE, it is also designed to retain the three most
+12 ; recent audit records, regardless of how old they are.
+13 ;
DQ NEW D,DA,DIC,DIK,ITEMDA,PRCPAUDT,PRCPCNT,PRCPSTOP,X
+1 ; loop through for each item
+2 SET ITEMDA=0
+3 FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if +ITEMDA'>0
QUIT
Begin DoDot:1
+4 NEW X,PRCPKEEP
+5 IF $DATA(SCAN)
WRITE !,"ITEM # ",ITEMDA
+6 ; no audits on file
SET X=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,10,0))
if X=""
QUIT
+7 ; date of audit
SET X=$PIECE($GET(^PRCP(445,PRCP("I"),1,ITEMDA,10,X,0)),"^",1)
+8 IF $DATA(SCAN)
WRITE !,"OLDEST AUDIT DATE: ",X
+9 ; earliest audit is within retention period
IF X'<STOPDATE
QUIT
+10 ;
+11 ; Item has entries that could be purged, save 3 most recent entries
+12 SET PRCPAUDT="A"
SET PRCPCNT=0
SET PRCPSTOP=0
+13 ; Find 3 oldest entries then proceed to next section
+14 FOR
SET PRCPAUDT=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,10,PRCPAUDT),-1)
if '+PRCPAUDT
QUIT
Begin DoDot:2
+15 SET PRCPCNT=PRCPCNT+1
IF $DATA(SCAN)
WRITE !,"FOUND:",PRCPCNT
+16 ; keep three most recent audit records
IF PRCPCNT<4
SET PRCPKEEP(PRCPAUDT)=PRCPCNT
QUIT
+17 QUIT
End DoDot:2
if PRCPCNT=3
QUIT
+18 ;
+19 ; only 2 records exists and all must be kept
IF PRCPCNT<3
QUIT
+20 ; Loop through all audit records on file, starting with the oldest
+21 ; Continue processing until the audit date of a record follows the stop date or processing hits one of the 3 most recent records.
+22 SET PRCPAUDT=0
+23 FOR
SET PRCPAUDT=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,10,PRCPAUDT))
if '+PRCPAUDT
QUIT
Begin DoDot:2
+24 ; get date of audit record
SET X=$PIECE($GET(^PRCP(445,PRCP("I"),1,ITEMDA,10,PRCPAUDT,0)),"^",1)
+25 IF $DATA(SCAN)
WRITE !,"AUDIT DATE: ",X," STOPDATE:",STOPDATE
+26 ; no more to purge
IF X'<STOPDATE!$DATA(PRCPKEEP(PRCPAUDT))
SET PRCPSTOP=1
QUIT
+27 IF $DATA(SCAN)
WRITE !,X," WILL BE PURGED"
QUIT
+28 SET DIK="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",10,"
SET DA(1)=ITEMDA
SET DA(2)=PRCP("I")
SET DA=PRCPAUDT
DO ^DIK
KILL DIK,DA
End DoDot:2
IF PRCPSTOP
QUIT
End DoDot:1
+29 ;
+30 QUIT
+31 ;
TEST ; RUN WITHOUT DELETING AND WITH SCAN ON
+1 NEW SCAN
+2 SET SCAN=1
+3 SET STOPDATE=3060625
+4 ;S STOPDATE=3061125
+5 SET PRCP("I")=9
+6 DO DQ
+7 QUIT
