source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCG237P.m@ 1710

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

initial load of WorldVistAEHR

File size: 1.6 KB
RevLine 
[613]1PRCG237P ;WISC/BGJ - IFCAP 442 FILE CLEANUP (PURGE); 11/5/99 12:22pm ;9/20/00 12:56
2V ;;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 ;
14442(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
31UNLOAD ;
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
36KILL442(DA) ;
37 Q:'$D(^PRC(442,DA,0))
38 S DIK="^PRC(442," D ^DIK
39 K DIK
40 D KLL4406
41 Q
42KLL4406 ;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
Note: See TracBrowser for help on using the repository browser.