PRCGARP1 ;WIRMFO/CTB/BGJ-IFCAP PURGEMASTER ROUTINE FOR FILE 442 ;12/10/97 9:07 AM
V ;;5.1;IFCAP;**46,131,150**;Oct 20, 2000;Build 24
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*150 RGB 4/23/12 Control the node 0 counter for file 410
;kill (DIK) since DIK call does not handle descending file logic
START(X) ;
NEW BEGDA,ENDA,SITE,DIK,DA,MOP,ZNODE
S BEGDA=$P(X,"-",1),ENDA=+$P(X,"-",2),SITE=$P(X,";",2)
S DA=BEGDA-1
F S DA=$O(^PRC(443.9,DA)) Q:'DA!(DA>ENDA) D
. S ZNODE=$G(^PRC(443.9,DA,0)) Q:ZNODE=""
. I +$P(ZNODE,"^",4)'=SITE QUIT
. I $P(ZNODE,"^",2)=1 D REMOVE^PRCGARCH QUIT
. S MOP=$P(ZNODE,"^",3)
. S:MOP="" MOP="NULL"
. D @MOP
. D REMOVE^PRCGARCH
. QUIT
QUIT
IS ;;ISSUES
TA ;;TRAVEL
OTA ;;OPEN TRAVEL
;;enter code here to completely delete one entry in 442 of the types
;; listed above.
QUIT
AR ;;ACCOUNTS RECEIVABLE
N PRCHDA
QUIT:'$D(DA)
S PRCHDA=DA
Q:'$D(^PRC(442,PRCHDA,0))
D KILL442(PRCHDA)
QUIT
NULL ;;442 entry with no MOP
CI ;;CERTIFIED INVOICE
PIA ;;PAYMENT IN ADVANCE
DD ;;GUARANTEED DELIVERY
ST ;;INVOICE/RECEIVING REPORT
IF ;;IMPREST FUND/CASHIER
PC ;;PURCHASE CARD
AB ;;AUTOBANK
RQ ;;REQUISITION
N PRCHDA,PRCHFY,FY,X,I
QUIT:'$D(DA)
S PRCHDA=DA
Q:'$D(^PRC(442,PRCHDA,0))
D K2237(PRCHDA)
D K4215(PRCHDA)
;delete file 441,442.9 entries
D K4429(PRCHDA)
D P441^PRCGPPC1(PRCHDA)
;finally, delete 442 and 443.6 (amendments file)
D KILL442(PRCHDA)
D KILL4436(PRCHDA)
;
QUIT
1358 ;;1358
;;enter code here to completely delete one 1358
;delete 410 files, 421.5, 441, 442 files, and finally 442
N PRCHDA,X
QUIT:'$D(DA)
S PRCHDA=DA
Q:'$D(^PRC(442,PRCHDA,0))
D K2237(PRCHDA)
;delete 1358
D:$D(^PRC(424,"C",PRCHDA)) DL424^PRCGPPC1(PRCHDA)
D K4215(PRCHDA)
D K4429(PRCHDA)
D KLL4406(PRCHDA),KLL4219(PRCHDA)
;finally, delete 442
D KILL442(PRCHDA)
QUIT
K4215(PRCHDA) ;
NEW PRCFDA
S PRCFDA=0 F S PRCFDA=$O(^PRCF(421.5,"E",PRCHDA,PRCFDA)) Q:PRCFDA="" D KILL4215(PRCFDA)
QUIT
KILL410(DA) ;
Q:'$D(^PRCS(410,DA,0))
S PRCIENCT=$P(^PRCS(410,0),"^",3) ;PRC*5.1*150
S DIK="^PRCS(410," D ^DIK
S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT ;PRC*5.1*150
K DIK
QUIT
KILL443(DA) ;
Q:'$D(^PRC(443,DA,0))
S DIK="^PRC(443," D ^DIK
K DIK
QUIT
KILL4215(DA) ;
S DIK="^PRCF(421.5," D ^DIK
K DIK
QUIT
KILL442(DA) ;
D KILL4101(DA)
D KLL4406(DA),KLL4219(DA)
S DIK="^PRC(442," D ^DIK
K DIK
QUIT
KILL4101(X) ;Delete 410.1 record when entry in 442 is deleted
;
N DA
S X=$P($G(^PRC(442,X,0)),"^")
Q:X'>0
S DIC(0)="X"
S DIC="^PRCS(410.1,"
D ^DIC
Q:Y=-1
S DA=+Y
S DIK="^PRCS(410.1," D ^DIK
K DIC,DIK,X,Y
QUIT
;
KILL4436(DA) ;
S DIK="^PRC(443.6," D ^DIK
K DIK
QUIT
K2237(PRCHDA) ;kill primary 2237
N PRCSDA
S PRCSDA=$P($G(^PRC(442,PRCHDA,0)),"^",12)
I +PRCSDA,$D(^PRCS(410,+PRCSDA)) D KILL410(PRCSDA)
;kill other 2237's if present
I $D(^PRC(442,PRCHDA,13)) D
.F I=1:1:20 S PRCSDA=$O(^PRC(442,PRCHDA,13,0)) Q:PRCSDA="" D
. . I $D(^PRCS(410,PRCSDA,0)) D KILL410(PRCSDA)
. . I $D(^PRC(443,PRCSDA,0)) D KILL443(PRCSDA)
. . QUIT
. QUIT
QUIT
K4429(PRCHDA) ;
N EXPONUM
S EXPONUM=$P($G(^PRC(442.9,PRCHDA,0)),"^",4) D:EXPONUM'="" P4429^PRCGPPC1(EXPONUM)
QUIT
KLL4406(DA) ;Delete 440.6 records when entry in 442 is deleted
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(DA) ;Delete 421.9 records when entry in 442 is deleted
N IPIEN,HLDDA,PONUM
S PONUM=$P($G(^PRC(442,DA,0)),"^") Q:$G(PONUM)=""
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,PONUM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGARP1 3871 printed Sep 23, 2025@19:40:53 Page 2
PRCGARP1 ;WIRMFO/CTB/BGJ-IFCAP PURGEMASTER ROUTINE FOR FILE 442 ;12/10/97 9:07 AM
V ;;5.1;IFCAP;**46,131,150**;Oct 20, 2000;Build 24
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*150 RGB 4/23/12 Control the node 0 counter for file 410
+4 ;kill (DIK) since DIK call does not handle descending file logic
START(X) ;
+1 NEW BEGDA,ENDA,SITE,DIK,DA,MOP,ZNODE
+2 SET BEGDA=$PIECE(X,"-",1)
SET ENDA=+$PIECE(X,"-",2)
SET SITE=$PIECE(X,";",2)
+3 SET DA=BEGDA-1
+4 FOR
SET DA=$ORDER(^PRC(443.9,DA))
if 'DA!(DA>ENDA)
QUIT
Begin DoDot:1
+5 SET ZNODE=$GET(^PRC(443.9,DA,0))
if ZNODE=""
QUIT
+6 IF +$PIECE(ZNODE,"^",4)'=SITE
QUIT
+7 IF $PIECE(ZNODE,"^",2)=1
DO REMOVE^PRCGARCH
QUIT
+8 SET MOP=$PIECE(ZNODE,"^",3)
+9 if MOP=""
SET MOP="NULL"
+10 DO @MOP
+11 DO REMOVE^PRCGARCH
+12 QUIT
End DoDot:1
+13 QUIT
IS ;;ISSUES
TA ;;TRAVEL
OTA ;;OPEN TRAVEL
+1 ;;enter code here to completely delete one entry in 442 of the types
+2 ;; listed above.
+3 QUIT
AR ;;ACCOUNTS RECEIVABLE
+1 NEW PRCHDA
+2 if '$DATA(DA)
QUIT
+3 SET PRCHDA=DA
+4 if '$DATA(^PRC(442,PRCHDA,0))
QUIT
+5 DO KILL442(PRCHDA)
+6 QUIT
NULL ;;442 entry with no MOP
CI ;;CERTIFIED INVOICE
PIA ;;PAYMENT IN ADVANCE
DD ;;GUARANTEED DELIVERY
ST ;;INVOICE/RECEIVING REPORT
IF ;;IMPREST FUND/CASHIER
PC ;;PURCHASE CARD
AB ;;AUTOBANK
RQ ;;REQUISITION
+1 NEW PRCHDA,PRCHFY,FY,X,I
+2 if '$DATA(DA)
QUIT
+3 SET PRCHDA=DA
+4 if '$DATA(^PRC(442,PRCHDA,0))
QUIT
+5 DO K2237(PRCHDA)
+6 DO K4215(PRCHDA)
+7 ;delete file 441,442.9 entries
+8 DO K4429(PRCHDA)
+9 DO P441^PRCGPPC1(PRCHDA)
+10 ;finally, delete 442 and 443.6 (amendments file)
+11 DO KILL442(PRCHDA)
+12 DO KILL4436(PRCHDA)
+13 ;
+14 QUIT
1358 ;;1358
+1 ;;enter code here to completely delete one 1358
+2 ;delete 410 files, 421.5, 441, 442 files, and finally 442
+3 NEW PRCHDA,X
+4 if '$DATA(DA)
QUIT
+5 SET PRCHDA=DA
+6 if '$DATA(^PRC(442,PRCHDA,0))
QUIT
+7 DO K2237(PRCHDA)
+8 ;delete 1358
+9 if $DATA(^PRC(424,"C",PRCHDA))
DO DL424^PRCGPPC1(PRCHDA)
+10 DO K4215(PRCHDA)
+11 DO K4429(PRCHDA)
+12 DO KLL4406(PRCHDA)
DO KLL4219(PRCHDA)
+13 ;finally, delete 442
+14 DO KILL442(PRCHDA)
+15 QUIT
K4215(PRCHDA) ;
+1 NEW PRCFDA
+2 SET PRCFDA=0
FOR
SET PRCFDA=$ORDER(^PRCF(421.5,"E",PRCHDA,PRCFDA))
if PRCFDA=""
QUIT
DO KILL4215(PRCFDA)
+3 QUIT
KILL410(DA) ;
+1 if '$DATA(^PRCS(410,DA,0))
QUIT
+2 ;PRC*5.1*150
SET PRCIENCT=$PIECE(^PRCS(410,0),"^",3)
+3 SET DIK="^PRCS(410,"
DO ^DIK
+4 ;PRC*5.1*150
SET $PIECE(^PRCS(410,0),"^",3)=PRCIENCT
KILL PRCIENCT
+5 KILL DIK
+6 QUIT
KILL443(DA) ;
+1 if '$DATA(^PRC(443,DA,0))
QUIT
+2 SET DIK="^PRC(443,"
DO ^DIK
+3 KILL DIK
+4 QUIT
KILL4215(DA) ;
+1 SET DIK="^PRCF(421.5,"
DO ^DIK
+2 KILL DIK
+3 QUIT
KILL442(DA) ;
+1 DO KILL4101(DA)
+2 DO KLL4406(DA)
DO KLL4219(DA)
+3 SET DIK="^PRC(442,"
DO ^DIK
+4 KILL DIK
+5 QUIT
KILL4101(X) ;Delete 410.1 record when entry in 442 is deleted
+1 ;
+2 NEW DA
+3 SET X=$PIECE($GET(^PRC(442,X,0)),"^")
+4 if X'>0
QUIT
+5 SET DIC(0)="X"
+6 SET DIC="^PRCS(410.1,"
+7 DO ^DIC
+8 if Y=-1
QUIT
+9 SET DA=+Y
+10 SET DIK="^PRCS(410.1,"
DO ^DIK
+11 KILL DIC,DIK,X,Y
+12 QUIT
+13 ;
KILL4436(DA) ;
+1 SET DIK="^PRC(443.6,"
DO ^DIK
+2 KILL DIK
+3 QUIT
K2237(PRCHDA) ;kill primary 2237
+1 NEW PRCSDA
+2 SET PRCSDA=$PIECE($GET(^PRC(442,PRCHDA,0)),"^",12)
+3 IF +PRCSDA
IF $DATA(^PRCS(410,+PRCSDA))
DO KILL410(PRCSDA)
+4 ;kill other 2237's if present
+5 IF $DATA(^PRC(442,PRCHDA,13))
Begin DoDot:1
+6 FOR I=1:1:20
SET PRCSDA=$ORDER(^PRC(442,PRCHDA,13,0))
if PRCSDA=""
QUIT
Begin DoDot:2
+7 IF $DATA(^PRCS(410,PRCSDA,0))
DO KILL410(PRCSDA)
+8 IF $DATA(^PRC(443,PRCSDA,0))
DO KILL443(PRCSDA)
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
K4429(PRCHDA) ;
+1 NEW EXPONUM
+2 SET EXPONUM=$PIECE($GET(^PRC(442.9,PRCHDA,0)),"^",4)
if EXPONUM'=""
DO P4429^PRCGPPC1(EXPONUM)
+3 QUIT
KLL4406(DA) ;Delete 440.6 records when entry in 442 is deleted
+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(DA) ;Delete 421.9 records when entry in 442 is deleted
+1 NEW IPIEN,HLDDA,PONUM
+2 SET PONUM=$PIECE($GET(^PRC(442,DA,0)),"^")
if $GET(PONUM)=""
QUIT
+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,PONUM
+10 QUIT
