PRCG237P ;WISC/BGJ - IFCAP 442 FILE CLEANUP (PURGE); 11/5/99 12:22pm ;9/20/00 12:56
V ;;5.1;IFCAP;**95,131**;Oct 20, 2000;Build 13
;Per VHA Directive 2004-038, this routine should not be modified.
;This routine is installed by patch PRC*5*237.
;The purpose of this routine is to clean up Accounts Receivable entries
;in file 442 that were not purged by running the Archive/Purge
;functionality. It will also purge entries in file 442 that do not
;have a date in the P.O. DATE field (DATE P.O. ASSIGNED field is used
;for comparison). Routine PRCG237Q is a routine installed by patch
;237 that queues entries into PurgeMaster for purging. Those entries
;are then purged by this routine as PurgeMaster cycles through file
;443.1 (PurgeMaster Worklist).
;
442(X) ;
N DA,KDA,BEGDA,ENDA,PODATE,DTPOASN,SITE,DATE,ZERONODE,MOP,PONUM
D UNLOAD
F S DA=$O(^PRC(442,DA)) Q:'DA!(DA>ENDA) D
. S ZERONODE=$G(^PRC(442,DA,0)),PONUM=$P(ZERONODE,"^")
. I $P(ZERONODE,"-")'=SITE Q
. S PODATE=$P($G(^PRC(442,DA,1)),"^",15)
. I PODATE>DATE Q
. I +PODATE=0 D Q
. . S DTPOASN=$P($P($G(^PRC(442,DA,12)),"^",5),".")
. . I DTPOASN>DATE Q
. . S KDA=DA D KILL442(KDA)
. S MOP=$P(ZERONODE,"^",2),PONUM=$P(ZERONODE,"^")
. I 'MOP Q
. S MOP=$P($G(^PRCD(442.5,MOP,0)),"^",2)
. I MOP="AR" S KDA=DA D KILL442(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
KILL442(DA) ;
Q:'$D(^PRC(442,DA,0))
S DIK="^PRC(442," D ^DIK
K DIK
D KLL4406,KLL4219
Q
KLL4406 ;find/kill invalid records in file 440.6
N IPIEN,HLDDA
S IPIEN=0,HLDDA=0
F S IPIEN=$O(^PRCH(440.6,"PO",DA,IPIEN)) Q:IPIEN'>0 D
.S HLDDA=DA,DA=IPIEN
.S DIK="^PRCH(440.6," D ^DIK
.K DIK
.S DA=HLDDA
K IPIEN,HLDDA
Q
KLL4219 ;find/kill invalid records in file 421.9
Q:$G(PONUM)=""
N IPIEN,HLDDA
S IPIEN=0,HLDDA=DA
F S IPIEN=$O(^PRCF(421.9,"B",PONUM,IPIEN)) Q:IPIEN'>0 D
.S DA=IPIEN
.S DIK="^PRCF(421.9," D ^DIK
.K DIK
S DA=HLDDA
K IPIEN,HLDDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCG237P 2042 printed Sep 23, 2025@19:40:41 Page 2
PRCG237P ;WISC/BGJ - IFCAP 442 FILE CLEANUP (PURGE); 11/5/99 12:22pm ;9/20/00 12:56
V ;;5.1;IFCAP;**95,131**;Oct 20, 2000;Build 13
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;This routine is installed by patch PRC*5*237.
+3 ;The purpose of this routine is to clean up Accounts Receivable entries
+4 ;in file 442 that were not purged by running the Archive/Purge
+5 ;functionality. It will also purge entries in file 442 that do not
+6 ;have a date in the P.O. DATE field (DATE P.O. ASSIGNED field is used
+7 ;for comparison). Routine PRCG237Q is a routine installed by patch
+8 ;237 that queues entries into PurgeMaster for purging. Those entries
+9 ;are then purged by this routine as PurgeMaster cycles through file
+10 ;443.1 (PurgeMaster Worklist).
+11 ;
442(X) ;
+1 NEW DA,KDA,BEGDA,ENDA,PODATE,DTPOASN,SITE,DATE,ZERONODE,MOP,PONUM
+2 DO UNLOAD
+3 FOR
SET DA=$ORDER(^PRC(442,DA))
if 'DA!(DA>ENDA)
QUIT
Begin DoDot:1
+4 SET ZERONODE=$GET(^PRC(442,DA,0))
SET PONUM=$PIECE(ZERONODE,"^")
+5 IF $PIECE(ZERONODE,"-")'=SITE
QUIT
+6 SET PODATE=$PIECE($GET(^PRC(442,DA,1)),"^",15)
+7 IF PODATE>DATE
QUIT
+8 IF +PODATE=0
Begin DoDot:2
+9 SET DTPOASN=$PIECE($PIECE($GET(^PRC(442,DA,12)),"^",5),".")
+10 IF DTPOASN>DATE
QUIT
+11 SET KDA=DA
DO KILL442(KDA)
End DoDot:2
QUIT
+12 SET MOP=$PIECE(ZERONODE,"^",2)
SET PONUM=$PIECE(ZERONODE,"^")
+13 IF 'MOP
QUIT
+14 SET MOP=$PIECE($GET(^PRCD(442.5,MOP,0)),"^",2)
+15 IF MOP="AR"
SET KDA=DA
DO KILL442(KDA)
End DoDot:1
+16 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
KILL442(DA) ;
+1 if '$DATA(^PRC(442,DA,0))
QUIT
+2 SET DIK="^PRC(442,"
DO ^DIK
+3 KILL DIK
+4 DO KLL4406
DO KLL4219
+5 QUIT
KLL4406 ;find/kill invalid records in file 440.6
+1 NEW IPIEN,HLDDA
+2 SET IPIEN=0
SET HLDDA=0
+3 FOR
SET IPIEN=$ORDER(^PRCH(440.6,"PO",DA,IPIEN))
if IPIEN'>0
QUIT
Begin DoDot:1
+4 SET HLDDA=DA
SET DA=IPIEN
+5 SET DIK="^PRCH(440.6,"
DO ^DIK
+6 KILL DIK
+7 SET DA=HLDDA
End DoDot:1
+8 KILL IPIEN,HLDDA
+9 QUIT
KLL4219 ;find/kill invalid records in file 421.9
+1 if $GET(PONUM)=""
QUIT
+2 NEW IPIEN,HLDDA
+3 SET IPIEN=0
SET HLDDA=DA
+4 FOR
SET IPIEN=$ORDER(^PRCF(421.9,"B",PONUM,IPIEN))
if IPIEN'>0
QUIT
Begin DoDot:1
+5 SET DA=IPIEN
+6 SET DIK="^PRCF(421.9,"
DO ^DIK
+7 KILL DIK
End DoDot:1
+8 SET DA=HLDDA
+9 KILL IPIEN,HLDDA
+10 QUIT
