| 1 | PRCGARP1 ;WIRMFO/CTB/BGJ-IFCAP PURGEMASTER ROUTINE FOR FILE 442 ;12/10/97 9:07 AM
|
|---|
| 2 | V ;;5.1;IFCAP;**46**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | START(X) ;
|
|---|
| 5 | NEW BEGDA,ENDA,SITE,DIK,DA
|
|---|
| 6 | S BEGDA=$P(X,"-",1),ENDA=+$P(X,"-",2),SITE=$P(X,";",2)
|
|---|
| 7 | S DA=BEGDA-1
|
|---|
| 8 | F S DA=$O(^PRC(443.9,DA)) Q:'DA!(DA>ENDA) D
|
|---|
| 9 | . S ZNODE=$G(^PRC(443.9,DA,0)) Q:ZNODE=""
|
|---|
| 10 | . I +$P(ZNODE,"^",4)'=SITE QUIT
|
|---|
| 11 | . I $P(ZNODE,"^",2)=1 D REMOVE^PRCGARCH QUIT
|
|---|
| 12 | . S MOP=$P(ZNODE,"^",3)
|
|---|
| 13 | . S:MOP="" MOP="NULL"
|
|---|
| 14 | . D @MOP
|
|---|
| 15 | . D REMOVE^PRCGARCH
|
|---|
| 16 | . QUIT
|
|---|
| 17 | QUIT
|
|---|
| 18 | IS ;;ISSUES
|
|---|
| 19 | TA ;;TRAVEL
|
|---|
| 20 | OTA ;;OPEN TRAVEL
|
|---|
| 21 | ;;enter code here to completely delete one entry in 442 of the types
|
|---|
| 22 | ;; listed above.
|
|---|
| 23 | QUIT
|
|---|
| 24 | AR ;;ACCOUNTS RECEIVABLE
|
|---|
| 25 | N PRCHDA
|
|---|
| 26 | QUIT:'$D(DA)
|
|---|
| 27 | S PRCHDA=DA
|
|---|
| 28 | Q:'$D(^PRC(442,PRCHDA,0))
|
|---|
| 29 | D KILL442(PRCHDA)
|
|---|
| 30 | QUIT
|
|---|
| 31 | NULL ;;442 entry with no MOP
|
|---|
| 32 | CI ;;CERTIFIED INVOICE
|
|---|
| 33 | PIA ;;PAYMENT IN ADVANCE
|
|---|
| 34 | DD ;;GUARANTEED DELIVERY
|
|---|
| 35 | ST ;;INVOICE/RECEIVING REPORT
|
|---|
| 36 | IF ;;IMPREST FUND/CASHIER
|
|---|
| 37 | PC ;;PURCHASE CARD
|
|---|
| 38 | AB ;;AUTOBANK
|
|---|
| 39 | RQ ;;REQUISITION
|
|---|
| 40 | N PRCHDA,PRCHFY,FY,X,I
|
|---|
| 41 | QUIT:'$D(DA)
|
|---|
| 42 | S PRCHDA=DA
|
|---|
| 43 | Q:'$D(^PRC(442,PRCHDA,0))
|
|---|
| 44 | D K2237(PRCHDA)
|
|---|
| 45 | D K4215(PRCHDA)
|
|---|
| 46 | ;delete file 441,442.9 entries
|
|---|
| 47 | D K4429(PRCHDA)
|
|---|
| 48 | D P441^PRCGPPC1(PRCHDA)
|
|---|
| 49 | ;finally, delete 442 and 443.6 (amendments file)
|
|---|
| 50 | D KILL442(PRCHDA)
|
|---|
| 51 | D KILL4436(PRCHDA)
|
|---|
| 52 | ;
|
|---|
| 53 | QUIT
|
|---|
| 54 | 1358 ;;1358
|
|---|
| 55 | ;;enter code here to completely delete one 1358
|
|---|
| 56 | ;delete 410 files, 421.5, 441, 442 files, and finally 442
|
|---|
| 57 | N PRCHDA,X
|
|---|
| 58 | QUIT:'$D(DA)
|
|---|
| 59 | S PRCHDA=DA
|
|---|
| 60 | Q:'$D(^PRC(442,PRCHDA,0))
|
|---|
| 61 | D K2237(PRCHDA)
|
|---|
| 62 | ;delete 1358
|
|---|
| 63 | D:$D(^PRC(424,"C",PRCHDA)) DL424^PRCGPPC1(PRCHDA)
|
|---|
| 64 | D K4215(PRCHDA)
|
|---|
| 65 | D K4429(PRCHDA)
|
|---|
| 66 | ;finally, delete 442
|
|---|
| 67 | D KILL442(PRCHDA)
|
|---|
| 68 | QUIT
|
|---|
| 69 | K4215(PRCHDA) ;
|
|---|
| 70 | NEW PRCFDA
|
|---|
| 71 | S PRCFDA=0 F S PRCFDA=$O(^PRCF(421.5,"E",PRCHDA,PRCFDA)) Q:PRCFDA="" D KILL4215(PRCFDA)
|
|---|
| 72 | QUIT
|
|---|
| 73 | KILL410(DA) ;
|
|---|
| 74 | Q:'$D(^PRCS(410,DA,0))
|
|---|
| 75 | S DIK="^PRCS(410," D ^DIK
|
|---|
| 76 | K DIK
|
|---|
| 77 | QUIT
|
|---|
| 78 | KILL443(DA) ;
|
|---|
| 79 | Q:'$D(^PRC(443,DA,0))
|
|---|
| 80 | S DIK="^PRC(443," D ^DIK
|
|---|
| 81 | K DIK
|
|---|
| 82 | QUIT
|
|---|
| 83 | KILL4215(DA) ;
|
|---|
| 84 | S DIK="^PRCF(421.5," D ^DIK
|
|---|
| 85 | K DIK
|
|---|
| 86 | QUIT
|
|---|
| 87 | KILL442(DA) ;
|
|---|
| 88 | D KILL4101(DA)
|
|---|
| 89 | S DIK="^PRC(442," D ^DIK
|
|---|
| 90 | K DIK
|
|---|
| 91 | QUIT
|
|---|
| 92 | KILL4101(X) ;Delete 410.1 record when entry in 442 is deleted
|
|---|
| 93 | ;
|
|---|
| 94 | N DA
|
|---|
| 95 | S X=$P($G(^PRC(442,X,0)),"^")
|
|---|
| 96 | Q:X'>0
|
|---|
| 97 | S DIC(0)="X"
|
|---|
| 98 | S DIC="^PRCS(410.1,"
|
|---|
| 99 | D ^DIC
|
|---|
| 100 | Q:Y=-1
|
|---|
| 101 | S DA=+Y
|
|---|
| 102 | S DIK="^PRCS(410.1," D ^DIK
|
|---|
| 103 | K DIC,DIK,X
|
|---|
| 104 | QUIT
|
|---|
| 105 | ;
|
|---|
| 106 | KILL4436(DA) ;
|
|---|
| 107 | S DIK="^PRC(443.6," D ^DIK
|
|---|
| 108 | K DIK
|
|---|
| 109 | QUIT
|
|---|
| 110 | K2237(PRCHDA) ;kill primary 2237
|
|---|
| 111 | N PRCSDA
|
|---|
| 112 | S PRCSDA=$P($G(^PRC(442,PRCHDA,0)),"^",12)
|
|---|
| 113 | I +PRCSDA,$D(^PRCS(410,+PRCSDA)) D KILL410(PRCSDA)
|
|---|
| 114 | ;kill other 2237's if present
|
|---|
| 115 | I $D(^PRC(442,PRCHDA,13)) D
|
|---|
| 116 | .F I=1:1:20 S PRCSDA=$O(^PRC(442,PRCHDA,13,0)) Q:PRCSDA="" D
|
|---|
| 117 | . . I $D(^PRCS(410,PRCSDA,0)) D KILL410(PRCSDA)
|
|---|
| 118 | . . I $D(^PRC(443,PRCSDA,0)) D KILL443(PRCSDA)
|
|---|
| 119 | . . QUIT
|
|---|
| 120 | . QUIT
|
|---|
| 121 | QUIT
|
|---|
| 122 | K4429(PRCHDA) ;
|
|---|
| 123 | N EXPONUM
|
|---|
| 124 | S EXPONUM=$P($G(^PRC(442.9,PRCHDA,0)),"^",4) D:EXPONUM'="" P4429^PRCGPPC1(EXPONUM)
|
|---|
| 125 | QUIT
|
|---|
