126 lines
2.8 KiB
Mathematica
126 lines
2.8 KiB
Mathematica
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
|