source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCGARP1.m@ 1607

PRCGARP1 ;WIRMFO/CTB/BGJ-IFCAP PURGEMASTER ROUTINE FOR FILE 442 ;12/10/97  9:07 AM
V ;;5.1;IFCAP;**46**;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
START(X) ;
 NEW BEGDA,ENDA,SITE,DIK,DA
 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)
 ;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 DIK="^PRCS(410," D ^DIK
 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)
 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
 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