| [613] | 1 | PRCG237P ;WISC/BGJ - IFCAP 442 FILE CLEANUP (PURGE); 11/5/99 12:22pm ;9/20/00 12:56
|
|---|
| 2 | V ;;5.1;IFCAP;**95**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;This routine is installed by patch PRC*5*237.
|
|---|
| 5 | ;The purpose of this routine is to clean up Accounts Receivable entries
|
|---|
| 6 | ;in file 442 that were not purged by running the Archive/Purge
|
|---|
| 7 | ;functionality. It will also purge entries in file 442 that do not
|
|---|
| 8 | ;have a date in the P.O. DATE field (DATE P.O. ASSIGNED field is used
|
|---|
| 9 | ;for comparison). Routine PRCG237Q is a routine installed by patch
|
|---|
| 10 | ;237 that queues entries into PurgeMaster for purging. Those entries
|
|---|
| 11 | ;are then purged by this routine as PurgeMaster cycles through file
|
|---|
| 12 | ;443.1 (PurgeMaster Worklist).
|
|---|
| 13 | ;
|
|---|
| 14 | 442(X) ;
|
|---|
| 15 | N DA,KDA,BEGDA,ENDA,PODATE,DTPOASN,SITE,DATE,ZERONODE,MOP
|
|---|
| 16 | D UNLOAD
|
|---|
| 17 | F S DA=$O(^PRC(442,DA)) Q:'DA!(DA>ENDA) D
|
|---|
| 18 | . S ZERONODE=$G(^PRC(442,DA,0))
|
|---|
| 19 | . I $P(ZERONODE,"-")'=SITE Q
|
|---|
| 20 | . S PODATE=$P($G(^PRC(442,DA,1)),"^",15)
|
|---|
| 21 | . I PODATE>DATE Q
|
|---|
| 22 | . I +PODATE=0 D Q
|
|---|
| 23 | . . S DTPOASN=$P($P($G(^PRC(442,DA,12)),"^",5),".")
|
|---|
| 24 | . . I DTPOASN>DATE Q
|
|---|
| 25 | . . S KDA=DA D KILL442(KDA)
|
|---|
| 26 | . S MOP=$P(ZERONODE,"^",2)
|
|---|
| 27 | . I 'MOP Q
|
|---|
| 28 | . S MOP=$P($G(^PRCD(442.5,MOP,0)),"^",2)
|
|---|
| 29 | . I MOP="AR" S KDA=DA D KILL442(KDA)
|
|---|
| 30 | Q
|
|---|
| 31 | UNLOAD ;
|
|---|
| 32 | S BEGDA=$P(X,"-",1),ENDA=+$P(X,"-",2),SITE=$P(X,";",2)
|
|---|
| 33 | S DATE=$P(X,";",3)
|
|---|
| 34 | S DA=BEGDA-.1
|
|---|
| 35 | Q
|
|---|
| 36 | KILL442(DA) ;
|
|---|
| 37 | Q:'$D(^PRC(442,DA,0))
|
|---|
| 38 | S DIK="^PRC(442," D ^DIK
|
|---|
| 39 | K DIK
|
|---|
| 40 | D KLL4406
|
|---|
| 41 | Q
|
|---|
| 42 | KLL4406 ;find/kill invalid records in file 440.6
|
|---|
| 43 | N IPIEN,HLDDA
|
|---|
| 44 | S IPIEN=0,HLDDA=0
|
|---|
| 45 | F S IPIEN=$O(^PRCH(440.6,"PO",DA,IPIEN)) Q:IPIEN'>0 D
|
|---|
| 46 | .S HLDDA=DA,DA=IPIEN
|
|---|
| 47 | .S DIK="^PRCH(440.6," D ^DIK
|
|---|
| 48 | .K DIK
|
|---|
| 49 | .S DA=HLDDA
|
|---|
| 50 | K IPIEN,HLDDA
|
|---|
| 51 | Q
|
|---|
