source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCG238P.m@ 1608

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

initial load of WorldVistAEHR
File size: 4.5 KB
RevLine 
[613]1PRCG238P ;WISC/BGJ-IFCAP 410 FILE CLEANUP (PURGE) ;11/5/99
2V ;;5.1;IFCAP;**95**;Oct 20, 2000
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;This routine is installed by patch PRC*5*238.
5 ;The purpose of this routine is to cleanup entries in files 410, 410.1
6 ;and 443 that are leftover after running the Archive/Purge
7 ;functionality. Routine PRCG238Q is a routine installed by patch 238
8 ;that queues entries into PurgeMaster for purging. Those entries
9 ;are then purged by this routine as PurgeMaster cycles through file
10 ;443.1 (PurgeMaster Worklist).
11 ;
12410(X) ;
13 N DA,KDA,OK,X1,FORMTYPE,TRANTYPE,REQDATE,REQFY,PRCHDA,PONUM,REQID,TEMPID,BEGDA,ENDA,SITE,PERMDATE,TEMPDATE
14 D UNLOAD
15 F S DA=$O(^PRCS(410,DA)) Q:'DA!(DA>ENDA) D
16 . S OK=1
17 . ;Kill 410 record when no zeroth node
18 . S X=$G(^PRCS(410,DA,0)) I X="" S X="SYSPURG1",^(0)=X,^PRCS(410,"B","SYSPURG1",DA)="" S KDA=DA D KILL443(KDA),KILL410(KDA) Q
19 . S X1=$G(^PRCS(410,DA,1)),FORMTYPE=$P(X,"^",4),TRANTYPE=$P(X,"^",2),REQDATE=$P(X1,"^"),REQID=$P(X,"^"),TEMPID=$P(X,"^",3)
20 . I $P(REQID,"-")'=SITE Q
21 . S PRCHDA=$P($G(^PRCS(410,DA,10)),"^",3),PONUM=$E($P($G(^PRCS(410,DA,4)),"^",5),1,6) S:PONUM]"" PONUM=SITE_"-"_PONUM
22 . ;Ceiling transactions
23 . I TRANTYPE="C" D CEILING Q:'OK S KDA=DA D KILL443(KDA),KILL410(KDA) Q
24 . ;Kill temp request when request date <= date specified for temps
25 . I REQID=TEMPID,(REQDATE'>TEMPDATE) S KDA=DA D KILL443(KDA),KILL410(KDA) Q
26 . Q:'+REQID
27 . ;Do not delete when date of request > date specified for permanent requests
28 . I REQDATE>PERMDATE Q
29 . ;If no date of request, use the fiscal year from the txn #
30 . I '+REQDATE S REQFY=$P(REQID,"-",2),REQFY=$S(REQFY<70:3,1:2)_REQFY I REQFY>$E(PERMDATE,1,3) Q
31 . ;If no reference to purchase order or if PO referenced does not exist - kill record
32 . I PRCHDA]""!(PONUM]"") D Q
33 . . I PRCHDA]"",$D(^PRC(442,PRCHDA,0)) D CHKDT(REQDATE,PRCHDA) Q:'OK
34 . . I PONUM]"" S X=$O(^PRC(442,"B",PONUM,0)) I +X,$D(^PRC(442,+X,0)) D CHKDT(REQDATE,+X) Q:'OK
35 . . S KDA=DA D KILL443(KDA),KILL410(KDA)
36 . I PRCHDA="",PONUM="" S KDA=DA D KILL443(KDA),KILL410(KDA)
37 Q
38443(X) ;
39 N DA,BEGDA,ENDA,SITE
40 D UNLOAD
41 F S DA=$O(^PRC(443,DA)) Q:'DA!(DA>ENDA) D
42 . I '$D(^PRCS(410,DA,0)) S KDA=DA D KILL443(KDA)
43 Q
444101(X) ;
45 N DA,BEGDA,ENDA,SITE,PERMDATE,X0,LDA
46 D UNLOAD
47 F S DA=$O(^PRCS(410.1,DA)) Q:'DA!(DA>ENDA) D
48 . S X0=$G(^PRCS(410.1,DA,0)) Q:X0=""
49 . Q:SITE'=$P(X0,"-")
50 . S LDA=$P(X0,"^",3)
51 . Q:LDA>PERMDATE
52 . S DIK="^PRCS(410.1," D ^DIK
53 . K DIK
54 Q
55UNLOAD ;
56 S BEGDA=$P(X,"-",1),ENDA=+$P(X,"-",2),SITE=$P(X,";",2)
57 S X=$P(X,";",3)
58 I X]"" S TEMPDATE=$P(X,"-",1),PERMDATE=$P(X,"-",2)
59 S DA=BEGDA-.1
60 Q
61CHKDT(RDATE,PODA) ;
62 N PODATE
63 ;Use DATE PO ASSIGNED field if defined, else use PO DATE
64 S PODATE=$P($P($G(^PRC(442,PODA,12)),"^",5),".")
65 I +PODATE=0 S PODATE=$P($G(^PRC(442,PODA,1)),"^",15) Q:'+PODATE
66 I '+RDATE D Q
67 . I REQFY<$E(PODATE,1,3) Q
68 . S OK=0
69 I $E(RDATE,1,3)<$E(PODATE,1,3) Q
70 S OK=0
71 Q
72CEILING ;
73 N ALLOCDT,REQFY
74 S ALLOCDT=$P($G(^PRCS(410,DA,6)),"^",2)
75 I +ALLOCDT'=0,ALLOCDT>PERMDATE S OK=0 Q
76 S REQFY=$P(REQID,"-",2),REQFY=$S(REQFY<70:3,1:2)_REQFY
77 I REQFY>$E(PERMDATE,1,3) S OK=0 Q
78 I PRCHDA]""!(PONUM]"") D
79 . I PRCHDA]"",$D(^PRC(442,PRCHDA,0)) D CHKDT(ALLOCDT,PRCHDA) Q:'OK
80 . I PONUM]"" S X=$O(^PRC(442,"B",PONUM,0)) I +X,$D(^PRC(442,+X,0)) D CHKDT(ALLOCDT,+X)
81 Q
82KILL410(DA) ;
83 Q:'$D(^PRCS(410,DA,0))
84 S DIK="^PRCS(410," D ^DIK
85 K DIK
86 D KILL4101
87 Q
88KILL443(DA) ;
89 Q:'$D(^PRC(443,DA,0))
90 S DIK="^PRC(443," D ^DIK
91 K DIK
92 Q
93KILL4101 ;
94 Q:$G(REQID)=""
95 N DA,ID1,ID2,ID3,ID,LDA
96 S ID1=$P(REQID,"-")_"-"_$P(REQID,"-",2)_"-"_$P(REQID,"-",4)
97 S ID2=$G(PONUM)
98 S ID3=REQID
99 F ID=ID1,ID2,ID3 I ID'="",$D(^PRCS(410.1,"B",ID)) D
100 . S DA=$O(^PRCS(410.1,"B",ID,0))
101 . Q:DA=""
102 . Q:'$D(^PRCS(410.1,DA,0))
103 . S LDA=$P(^PRCS(410.1,DA,0),"^",3)
104 . Q:LDA>PERMDATE
105 . S DIK="^PRCS(410.1," D ^DIK
106 . K DIK
107 Q
108FIND445 ;find invalid records in file 445
109 S IPIEN=0
110 F S IPIEN=$O(^PRCP(445,IPIEN)) Q:IPIEN'>0 D
111 .S IEN=0
112 .F S IEN=$O(^PRCP(445,IPIEN,1,IEN)) Q:IEN'>0 D
113 ..Q:'$D(^PRCP(445,IPIEN,1,IEN,7))
114 ..S TTLI=$P(^PRCP(445,IPIEN,1,IEN,7,0),U,4)
115 ..S ITIEN=0
116 ..F S ITIEN=$O(^PRCP(445,IPIEN,1,IEN,7,ITIEN)) Q:ITIEN'>0 D
117 ...I '$D(^PRCS(410,ITIEN)) D KILL445
118 ..S $P(^PRCP(445,IPIEN,1,IEN,7,0),U,4)=TTLI
119 ..;-leave this with zero amount don't delete? - I TTLI=0 S ^PRCP(445,IPIEN,1,IEN,7) Q
120 ..Q
121 .Q
122 K IPIEN,IEN,ITIEN,TTLI
123 Q
124KILL445 ;clear the invalid records
125 Q:'$D(^PRCP(445,IPIEN,1,IEN,7,ITIEN,0))
126 S HLDDA=DA,DA(2)=IPIEN,DA(1)=IEN,DA=ITIEN
127 S DIK="^PRCP(445,"_DA(2)_",1,"_DA(1)_",7,"
128 D ^DIK
129 K DIK
130 S TTLI=TTLI-1
131 S DA=HLDDA
132 Q
Note: See TracBrowser for help on using the repository browser.