PRCG238P ;WISC/BGJ-IFCAP 410 FILE CLEANUP (PURGE) ;11/5/99
V ;;5.1;IFCAP;**95**;Oct 20, 2000
;Per VHA Directive 2004-038, this routine should not be modified.
;This routine is installed by patch PRC*5*238.
;The purpose of this routine is to cleanup entries in files 410, 410.1
;and 443 that are leftover after running the Archive/Purge
;functionality. Routine PRCG238Q is a routine installed by patch 238
;that queues entries into PurgeMaster for purging. Those entries
;are then purged by this routine as PurgeMaster cycles through file
;443.1 (PurgeMaster Worklist).
;
410(X) ;
N DA,KDA,OK,X1,FORMTYPE,TRANTYPE,REQDATE,REQFY,PRCHDA,PONUM,REQID,TEMPID,BEGDA,ENDA,SITE,PERMDATE,TEMPDATE
D UNLOAD
F S DA=$O(^PRCS(410,DA)) Q:'DA!(DA>ENDA) D
. S OK=1
. ;Kill 410 record when no zeroth node
. S X=$G(^PRCS(410,DA,0)) I X="" S X="SYSPURG1",^(0)=X,^PRCS(410,"B","SYSPURG1",DA)="" S KDA=DA D KILL443(KDA),KILL410(KDA) Q
. S X1=$G(^PRCS(410,DA,1)),FORMTYPE=$P(X,"^",4),TRANTYPE=$P(X,"^",2),REQDATE=$P(X1,"^"),REQID=$P(X,"^"),TEMPID=$P(X,"^",3)
. I $P(REQID,"-")'=SITE Q
. S PRCHDA=$P($G(^PRCS(410,DA,10)),"^",3),PONUM=$E($P($G(^PRCS(410,DA,4)),"^",5),1,6) S:PONUM]"" PONUM=SITE_"-"_PONUM
. ;Ceiling transactions
. I TRANTYPE="C" D CEILING Q:'OK S KDA=DA D KILL443(KDA),KILL410(KDA) Q
. ;Kill temp request when request date <= date specified for temps
. I REQID=TEMPID,(REQDATE'>TEMPDATE) S KDA=DA D KILL443(KDA),KILL410(KDA) Q
. Q:'+REQID
. ;Do not delete when date of request > date specified for permanent requests
. I REQDATE>PERMDATE Q
. ;If no date of request, use the fiscal year from the txn #
. I '+REQDATE S REQFY=$P(REQID,"-",2),REQFY=$S(REQFY<70:3,1:2)_REQFY I REQFY>$E(PERMDATE,1,3) Q
. ;If no reference to purchase order or if PO referenced does not exist - kill record
. I PRCHDA]""!(PONUM]"") D Q
. . I PRCHDA]"",$D(^PRC(442,PRCHDA,0)) D CHKDT(REQDATE,PRCHDA) Q:'OK
. . I PONUM]"" S X=$O(^PRC(442,"B",PONUM,0)) I +X,$D(^PRC(442,+X,0)) D CHKDT(REQDATE,+X) Q:'OK
. . S KDA=DA D KILL443(KDA),KILL410(KDA)
. I PRCHDA="",PONUM="" S KDA=DA D KILL443(KDA),KILL410(KDA)
Q
443(X) ;
N DA,BEGDA,ENDA,SITE
D UNLOAD
F S DA=$O(^PRC(443,DA)) Q:'DA!(DA>ENDA) D
. I '$D(^PRCS(410,DA,0)) S KDA=DA D KILL443(KDA)
Q
4101(X) ;
N DA,BEGDA,ENDA,SITE,PERMDATE,X0,LDA
D UNLOAD
F S DA=$O(^PRCS(410.1,DA)) Q:'DA!(DA>ENDA) D
. S X0=$G(^PRCS(410.1,DA,0)) Q:X0=""
. Q:SITE'=$P(X0,"-")
. S LDA=$P(X0,"^",3)
. Q:LDA>PERMDATE
. S DIK="^PRCS(410.1," D ^DIK
. K DIK
Q
UNLOAD ;
S BEGDA=$P(X,"-",1),ENDA=+$P(X,"-",2),SITE=$P(X,";",2)
S X=$P(X,";",3)
I X]"" S TEMPDATE=$P(X,"-",1),PERMDATE=$P(X,"-",2)
S DA=BEGDA-.1
Q
CHKDT(RDATE,PODA) ;
N PODATE
;Use DATE PO ASSIGNED field if defined, else use PO DATE
S PODATE=$P($P($G(^PRC(442,PODA,12)),"^",5),".")
I +PODATE=0 S PODATE=$P($G(^PRC(442,PODA,1)),"^",15) Q:'+PODATE
I '+RDATE D Q
. I REQFY<$E(PODATE,1,3) Q
. S OK=0
I $E(RDATE,1,3)<$E(PODATE,1,3) Q
S OK=0
Q
CEILING ;
N ALLOCDT,REQFY
S ALLOCDT=$P($G(^PRCS(410,DA,6)),"^",2)
I +ALLOCDT'=0,ALLOCDT>PERMDATE S OK=0 Q
S REQFY=$P(REQID,"-",2),REQFY=$S(REQFY<70:3,1:2)_REQFY
I REQFY>$E(PERMDATE,1,3) S OK=0 Q
I PRCHDA]""!(PONUM]"") D
. I PRCHDA]"",$D(^PRC(442,PRCHDA,0)) D CHKDT(ALLOCDT,PRCHDA) Q:'OK
. I PONUM]"" S X=$O(^PRC(442,"B",PONUM,0)) I +X,$D(^PRC(442,+X,0)) D CHKDT(ALLOCDT,+X)
Q
KILL410(DA) ;
Q:'$D(^PRCS(410,DA,0))
S DIK="^PRCS(410," D ^DIK
K DIK
D KILL4101
Q
KILL443(DA) ;
Q:'$D(^PRC(443,DA,0))
S DIK="^PRC(443," D ^DIK
K DIK
Q
KILL4101 ;
Q:$G(REQID)=""
N DA,ID1,ID2,ID3,ID,LDA
S ID1=$P(REQID,"-")_"-"_$P(REQID,"-",2)_"-"_$P(REQID,"-",4)
S ID2=$G(PONUM)
S ID3=REQID
F ID=ID1,ID2,ID3 I ID'="",$D(^PRCS(410.1,"B",ID)) D
. S DA=$O(^PRCS(410.1,"B",ID,0))
. Q:DA=""
. Q:'$D(^PRCS(410.1,DA,0))
. S LDA=$P(^PRCS(410.1,DA,0),"^",3)
. Q:LDA>PERMDATE
. S DIK="^PRCS(410.1," D ^DIK
. K DIK
Q
FIND445 ;find invalid records in file 445
S IPIEN=0
F S IPIEN=$O(^PRCP(445,IPIEN)) Q:IPIEN'>0 D
.S IEN=0
.F S IEN=$O(^PRCP(445,IPIEN,1,IEN)) Q:IEN'>0 D
..Q:'$D(^PRCP(445,IPIEN,1,IEN,7))
..S TTLI=$P(^PRCP(445,IPIEN,1,IEN,7,0),U,4)
..S ITIEN=0
..F S ITIEN=$O(^PRCP(445,IPIEN,1,IEN,7,ITIEN)) Q:ITIEN'>0 D
...I '$D(^PRCS(410,ITIEN)) D KILL445
..S $P(^PRCP(445,IPIEN,1,IEN,7,0),U,4)=TTLI
..;-leave this with zero amount don't delete? - I TTLI=0 S ^PRCP(445,IPIEN,1,IEN,7) Q
..Q
.Q
K IPIEN,IEN,ITIEN,TTLI
Q
KILL445 ;clear the invalid records
Q:'$D(^PRCP(445,IPIEN,1,IEN,7,ITIEN,0))
S HLDDA=DA,DA(2)=IPIEN,DA(1)=IEN,DA=ITIEN
S DIK="^PRCP(445,"_DA(2)_",1,"_DA(1)_",7,"
D ^DIK
K DIK
S TTLI=TTLI-1
S DA=HLDDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCG238P 4727 printed Dec 13, 2024@02:04:39 Page 2
PRCG238P ;WISC/BGJ-IFCAP 410 FILE CLEANUP (PURGE) ;11/5/99
V ;;5.1;IFCAP;**95**;Oct 20, 2000
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;This routine is installed by patch PRC*5*238.
+3 ;The purpose of this routine is to cleanup entries in files 410, 410.1
+4 ;and 443 that are leftover after running the Archive/Purge
+5 ;functionality. Routine PRCG238Q is a routine installed by patch 238
+6 ;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 ;
410(X) ;
+1 NEW DA,KDA,OK,X1,FORMTYPE,TRANTYPE,REQDATE,REQFY,PRCHDA,PONUM,REQID,TEMPID,BEGDA,ENDA,SITE,PERMDATE,TEMPDATE
+2 DO UNLOAD
+3 FOR
SET DA=$ORDER(^PRCS(410,DA))
if 'DA!(DA>ENDA)
QUIT
Begin DoDot:1
+4 SET OK=1
+5 ;Kill 410 record when no zeroth node
+6 SET X=$GET(^PRCS(410,DA,0))
IF X=""
SET X="SYSPURG1"
SET ^(0)=X
SET ^PRCS(410,"B","SYSPURG1",DA)=""
SET KDA=DA
DO KILL443(KDA)
DO KILL410(KDA)
QUIT
+7 SET X1=$GET(^PRCS(410,DA,1))
SET FORMTYPE=$PIECE(X,"^",4)
SET TRANTYPE=$PIECE(X,"^",2)
SET REQDATE=$PIECE(X1,"^")
SET REQID=$PIECE(X,"^")
SET TEMPID=$PIECE(X,"^",3)
+8 IF $PIECE(REQID,"-")'=SITE
QUIT
+9 SET PRCHDA=$PIECE($GET(^PRCS(410,DA,10)),"^",3)
SET PONUM=$EXTRACT($PIECE($GET(^PRCS(410,DA,4)),"^",5),1,6)
if PONUM]""
SET PONUM=SITE_"-"_PONUM
+10 ;Ceiling transactions
+11 IF TRANTYPE="C"
DO CEILING
if 'OK
QUIT
SET KDA=DA
DO KILL443(KDA)
DO KILL410(KDA)
QUIT
+12 ;Kill temp request when request date <= date specified for temps
+13 IF REQID=TEMPID
IF (REQDATE'>TEMPDATE)
SET KDA=DA
DO KILL443(KDA)
DO KILL410(KDA)
QUIT
+14 if '+REQID
QUIT
+15 ;Do not delete when date of request > date specified for permanent requests
+16 IF REQDATE>PERMDATE
QUIT
+17 ;If no date of request, use the fiscal year from the txn #
+18 IF '+REQDATE
SET REQFY=$PIECE(REQID,"-",2)
SET REQFY=$SELECT(REQFY<70:3,1:2)_REQFY
IF REQFY>$EXTRACT(PERMDATE,1,3)
QUIT
+19 ;If no reference to purchase order or if PO referenced does not exist - kill record
+20 IF PRCHDA]""!(PONUM]"")
Begin DoDot:2
+21 IF PRCHDA]""
IF $DATA(^PRC(442,PRCHDA,0))
DO CHKDT(REQDATE,PRCHDA)
if 'OK
QUIT
+22 IF PONUM]""
SET X=$ORDER(^PRC(442,"B",PONUM,0))
IF +X
IF $DATA(^PRC(442,+X,0))
DO CHKDT(REQDATE,+X)
if 'OK
QUIT
+23 SET KDA=DA
DO KILL443(KDA)
DO KILL410(KDA)
End DoDot:2
QUIT
+24 IF PRCHDA=""
IF PONUM=""
SET KDA=DA
DO KILL443(KDA)
DO KILL410(KDA)
End DoDot:1
+25 QUIT
443(X) ;
+1 NEW DA,BEGDA,ENDA,SITE
+2 DO UNLOAD
+3 FOR
SET DA=$ORDER(^PRC(443,DA))
if 'DA!(DA>ENDA)
QUIT
Begin DoDot:1
+4 IF '$DATA(^PRCS(410,DA,0))
SET KDA=DA
DO KILL443(KDA)
End DoDot:1
+5 QUIT
4101(X) ;
+1 NEW DA,BEGDA,ENDA,SITE,PERMDATE,X0,LDA
+2 DO UNLOAD
+3 FOR
SET DA=$ORDER(^PRCS(410.1,DA))
if 'DA!(DA>ENDA)
QUIT
Begin DoDot:1
+4 SET X0=$GET(^PRCS(410.1,DA,0))
if X0=""
QUIT
+5 if SITE'=$PIECE(X0,"-")
QUIT
+6 SET LDA=$PIECE(X0,"^",3)
+7 if LDA>PERMDATE
QUIT
+8 SET DIK="^PRCS(410.1,"
DO ^DIK
+9 KILL DIK
End DoDot:1
+10 QUIT
UNLOAD ;
+1 SET BEGDA=$PIECE(X,"-",1)
SET ENDA=+$PIECE(X,"-",2)
SET SITE=$PIECE(X,";",2)
+2 SET X=$PIECE(X,";",3)
+3 IF X]""
SET TEMPDATE=$PIECE(X,"-",1)
SET PERMDATE=$PIECE(X,"-",2)
+4 SET DA=BEGDA-.1
+5 QUIT
CHKDT(RDATE,PODA) ;
+1 NEW PODATE
+2 ;Use DATE PO ASSIGNED field if defined, else use PO DATE
+3 SET PODATE=$PIECE($PIECE($GET(^PRC(442,PODA,12)),"^",5),".")
+4 IF +PODATE=0
SET PODATE=$PIECE($GET(^PRC(442,PODA,1)),"^",15)
if '+PODATE
QUIT
+5 IF '+RDATE
Begin DoDot:1
+6 IF REQFY<$EXTRACT(PODATE,1,3)
QUIT
+7 SET OK=0
End DoDot:1
QUIT
+8 IF $EXTRACT(RDATE,1,3)<$EXTRACT(PODATE,1,3)
QUIT
+9 SET OK=0
+10 QUIT
CEILING ;
+1 NEW ALLOCDT,REQFY
+2 SET ALLOCDT=$PIECE($GET(^PRCS(410,DA,6)),"^",2)
+3 IF +ALLOCDT'=0
IF ALLOCDT>PERMDATE
SET OK=0
QUIT
+4 SET REQFY=$PIECE(REQID,"-",2)
SET REQFY=$SELECT(REQFY<70:3,1:2)_REQFY
+5 IF REQFY>$EXTRACT(PERMDATE,1,3)
SET OK=0
QUIT
+6 IF PRCHDA]""!(PONUM]"")
Begin DoDot:1
+7 IF PRCHDA]""
IF $DATA(^PRC(442,PRCHDA,0))
DO CHKDT(ALLOCDT,PRCHDA)
if 'OK
QUIT
+8 IF PONUM]""
SET X=$ORDER(^PRC(442,"B",PONUM,0))
IF +X
IF $DATA(^PRC(442,+X,0))
DO CHKDT(ALLOCDT,+X)
End DoDot:1
+9 QUIT
KILL410(DA) ;
+1 if '$DATA(^PRCS(410,DA,0))
QUIT
+2 SET DIK="^PRCS(410,"
DO ^DIK
+3 KILL DIK
+4 DO KILL4101
+5 QUIT
KILL443(DA) ;
+1 if '$DATA(^PRC(443,DA,0))
QUIT
+2 SET DIK="^PRC(443,"
DO ^DIK
+3 KILL DIK
+4 QUIT
KILL4101 ;
+1 if $GET(REQID)=""
QUIT
+2 NEW DA,ID1,ID2,ID3,ID,LDA
+3 SET ID1=$PIECE(REQID,"-")_"-"_$PIECE(REQID,"-",2)_"-"_$PIECE(REQID,"-",4)
+4 SET ID2=$GET(PONUM)
+5 SET ID3=REQID
+6 FOR ID=ID1,ID2,ID3
IF ID'=""
IF $DATA(^PRCS(410.1,"B",ID))
Begin DoDot:1
+7 SET DA=$ORDER(^PRCS(410.1,"B",ID,0))
+8 if DA=""
QUIT
+9 if '$DATA(^PRCS(410.1,DA,0))
QUIT
+10 SET LDA=$PIECE(^PRCS(410.1,DA,0),"^",3)
+11 if LDA>PERMDATE
QUIT
+12 SET DIK="^PRCS(410.1,"
DO ^DIK
+13 KILL DIK
End DoDot:1
+14 QUIT
FIND445 ;find invalid records in file 445
+1 SET IPIEN=0
+2 FOR
SET IPIEN=$ORDER(^PRCP(445,IPIEN))
if IPIEN'>0
QUIT
Begin DoDot:1
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(^PRCP(445,IPIEN,1,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+5 if '$DATA(^PRCP(445,IPIEN,1,IEN,7))
QUIT
+6 SET TTLI=$PIECE(^PRCP(445,IPIEN,1,IEN,7,0),U,4)
+7 SET ITIEN=0
+8 FOR
SET ITIEN=$ORDER(^PRCP(445,IPIEN,1,IEN,7,ITIEN))
if ITIEN'>0
QUIT
Begin DoDot:3
+9 IF '$DATA(^PRCS(410,ITIEN))
DO KILL445
End DoDot:3
+10 SET $PIECE(^PRCP(445,IPIEN,1,IEN,7,0),U,4)=TTLI
+11 ;-leave this with zero amount don't delete? - I TTLI=0 S ^PRCP(445,IPIEN,1,IEN,7) Q
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 KILL IPIEN,IEN,ITIEN,TTLI
+15 QUIT
KILL445 ;clear the invalid records
+1 if '$DATA(^PRCP(445,IPIEN,1,IEN,7,ITIEN,0))
QUIT
+2 SET HLDDA=DA
SET DA(2)=IPIEN
SET DA(1)=IEN
SET DA=ITIEN
+3 SET DIK="^PRCP(445,"_DA(2)_",1,"_DA(1)_",7,"
+4 DO ^DIK
+5 KILL DIK
+6 SET TTLI=TTLI-1
+7 SET DA=HLDDA
+8 QUIT
