source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCGARP1.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1PRCGARP1 ;WIRMFO/CTB/BGJ-IFCAP PURGEMASTER ROUTINE FOR FILE 442 ;12/10/97 9:07 AM
2V ;;5.1;IFCAP;**46**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4START(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
18IS ;;ISSUES
19TA ;;TRAVEL
20OTA ;;OPEN TRAVEL
21 ;;enter code here to completely delete one entry in 442 of the types
22 ;; listed above.
23 QUIT
24AR ;;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
31NULL ;;442 entry with no MOP
32CI ;;CERTIFIED INVOICE
33PIA ;;PAYMENT IN ADVANCE
34DD ;;GUARANTEED DELIVERY
35ST ;;INVOICE/RECEIVING REPORT
36IF ;;IMPREST FUND/CASHIER
37PC ;;PURCHASE CARD
38AB ;;AUTOBANK
39RQ ;;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
541358 ;;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
69K4215(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
73KILL410(DA) ;
74 Q:'$D(^PRCS(410,DA,0))
75 S DIK="^PRCS(410," D ^DIK
76 K DIK
77 QUIT
78KILL443(DA) ;
79 Q:'$D(^PRC(443,DA,0))
80 S DIK="^PRC(443," D ^DIK
81 K DIK
82 QUIT
83KILL4215(DA) ;
84 S DIK="^PRCF(421.5," D ^DIK
85 K DIK
86 QUIT
87KILL442(DA) ;
88 D KILL4101(DA)
89 S DIK="^PRC(442," D ^DIK
90 K DIK
91 QUIT
92KILL4101(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 ;
106KILL4436(DA) ;
107 S DIK="^PRC(443.6," D ^DIK
108 K DIK
109 QUIT
110K2237(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
122K4429(PRCHDA) ;
123 N EXPONUM
124 S EXPONUM=$P($G(^PRC(442.9,PRCHDA,0)),"^",4) D:EXPONUM'="" P4429^PRCGPPC1(EXPONUM)
125 QUIT
Note: See TracBrowser for help on using the repository browser.