- PRCG239P ;WISC/BGJ - IFCAP 442 FILE CLEANUP (PURGE); 11/5/99 12:22pm ;9/20/00 12:56
- V ;;5.1;IFCAP;**95,138**;Oct 20, 2000;Build 18
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;This routine is installed by patch PRC*5.1*95.
- ;The purpose of this routine is to clean up FMS reconciliation data
- ;in file 417 that were not purged by running the Archive/Purge
- ;functionality. Routine PRCG239Q is a routine installed by patch
- ;95 that queues entries into PurgeMaster for purging. Those entries
- ;are then purged by this routine as PurgeMaster cycles through file
- ;443.1 (PurgeMaster Worklist).
- ;
- 417(X) ;
- N DA,KDA,BEGDA,ENDA,PODATE,DTPOASN,SITE,DATE,ZERONODE,MOP
- D UNLOAD
- F S DA=$O(^PRCS(417,DA)) Q:'DA!(DA>ENDA) D
- . S ZERONODE=$G(^PRCS(417,DA,0)) Q:ZERONODE=""
- . S PODATE=$P($G(^PRCS(417,DA,0)),"^",22)
- . I PODATE>DATE Q
- . S KDA=DA D KILL417(KDA)
- Q
- UNLOAD ;
- S BEGDA=$P(X,"-",1),ENDA=+$P(X,"-",2),SITE=$P(X,";",2)
- S DATE=$P(X,";",3)
- S DA=BEGDA-.1
- Q
- KILL417(DA) ;
- Q:'$D(^PRCS(417,DA,0))
- S DIK="^PRCS(417," D ^DIK
- K DIK
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCG239P 1094 printed Feb 18, 2025@23:31:04 Page 2
- PRCG239P ;WISC/BGJ - IFCAP 442 FILE CLEANUP (PURGE); 11/5/99 12:22pm ;9/20/00 12:56
- V ;;5.1;IFCAP;**95,138**;Oct 20, 2000;Build 18
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 ;This routine is installed by patch PRC*5.1*95.
- +3 ;The purpose of this routine is to clean up FMS reconciliation data
- +4 ;in file 417 that were not purged by running the Archive/Purge
- +5 ;functionality. Routine PRCG239Q is a routine installed by patch
- +6 ;95 that queues entries into PurgeMaster for purging. Those entries
- +7 ;are then purged by this routine as PurgeMaster cycles through file
- +8 ;443.1 (PurgeMaster Worklist).
- +9 ;
- 417(X) ;
- +1 NEW DA,KDA,BEGDA,ENDA,PODATE,DTPOASN,SITE,DATE,ZERONODE,MOP
- +2 DO UNLOAD
- +3 FOR
- SET DA=$ORDER(^PRCS(417,DA))
- if 'DA!(DA>ENDA)
- QUIT
- Begin DoDot:1
- +4 SET ZERONODE=$GET(^PRCS(417,DA,0))
- if ZERONODE=""
- QUIT
- +5 SET PODATE=$PIECE($GET(^PRCS(417,DA,0)),"^",22)
- +6 IF PODATE>DATE
- QUIT
- +7 SET KDA=DA
- DO KILL417(KDA)
- End DoDot:1
- +8 QUIT
- UNLOAD ;
- +1 SET BEGDA=$PIECE(X,"-",1)
- SET ENDA=+$PIECE(X,"-",2)
- SET SITE=$PIECE(X,";",2)
- +2 SET DATE=$PIECE(X,";",3)
- +3 SET DA=BEGDA-.1
- +4 QUIT
- KILL417(DA) ;
- +1 if '$DATA(^PRCS(417,DA,0))
- QUIT
- +2 SET DIK="^PRCS(417,"
- DO ^DIK
- +3 KILL DIK
- +4 QUIT