source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFPRG1.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: 3.5 KB
Line 
1IBDFPRG1 ;ALB/AAS - AICS PURGE UTILITY ; 4-OCT-95
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4% ; -- purge utility for purging entries from the
5 ; Form Definition file (357.95)
6 ; Form Tracking file (357.96)
7 ; Form Specification file (359.2)
8 G MANUAL^IBDFPRG
9 ;
10 ;
11PURGFD(IBLDT) ; -- Procedure
12 ; -- purge entires in Form Definition file marked for deletion
13 ; that were marked before ibldt and no incomplete entries in
14 ; form tracking exist
15 ;
16 ; Input : ibldt := only purge records with a date marked for
17 ; deletion older than this date
18 ; Output: ibcnt5 := number of entries in 357.95 deleted
19 ; ibcnt2 := number of entries in 359.2 deleted
20 ;
21 N IBI,IBJ,IBSTAT,X,Y
22 S (IBCNT5,IBCNT2)=0
23 I IBLDT=""!(IBLDT'?7N) G PURGFDQ
24 S IBI=0
25 F S IBI=$O(^IBD(357.95,"ADEL",IBI)) Q:'IBI!(IBI'<IBLDT) D
26 .S IBJ=0
27 .F S IBJ=$O(^IBD(357.95,"ADEL",IBI,IBJ)) Q:'IBJ D
28 ..
29 ..; -- "a" x-ref is special x-ref of all forms not received
30 ..; for 357.95 check KILLTYPE^IBDF19
31 ..;
32 ..I $D(^IBD(357.96,"A",IBJ)) Q
33 ..I $D(^IBD(357.95,IBJ,0)) S X=$$DEL("^IBD(357.95,",IBJ),IBCNT5=IBCNT5+1
34 ..I $D(^IBD(359.2,IBJ,0)) S X=$$DEL("^IBD(359.2,",IBJ),IBCNT2=IBCNT2+1
35 ..Q
36 .Q
37 ;
38PURGFDQ Q
39 ;
40PURGFT(IBLDT,IBHOW) ; -- Procedure
41 ; -- purge entries from form tracking file (357.96)
42 ; Input : ibldt := only purge records with an appointment
43 ; date older than this date
44 ; ibhow := 0=no records, 1=complete, 2=all
45 ; Output: ibcnt6 := number of entries in 357.96 deleted
46 ;
47 N X,Y,IBI,IBJ,IBSTAT
48 S IBCNT6=0
49 I IBLDT=""!(IBLDT'?7N) G PURGFTQ
50 S IBHOW=+$G(IBHOW)
51 I IBHOW<0!(IBHOW>2) G PURGFTQ
52 ;
53 S IBI=0
54 F S IBI=$O(^IBD(357.96,"D",IBI)) Q:'IBI!(IBI'<IBLDT) D
55 .S IBJ=0
56 .F S IBJ=$O(^IBD(357.96,"D",IBI,IBJ)) Q:'IBJ D
57 ..I $$STATCHK(IBJ,IBHOW) S X=$$DEL("^IBD(357.96,",IBJ),IBCNT6=IBCNT6+1
58 ..Q
59 .Q
60PURGFTQ Q
61 ;
62PURGEL(IBLDT) ; --
63 ; -- Purge AICS Error Log older created prior to ibdldt
64 ; Input : ibldt := only purge error created prior to this date
65 ;
66 ; Output: ibcnt7 := number of entries in 359.3 deleted
67 ;
68 N IBI,IBJ
69 S (IBCNT7,IBI)=0
70 F S IBI=$O(^IBD(359.3,"B",IBI)) Q:'IBI!(IBI'<IBLDT) D
71 .S IBJ=0
72 .F S IBJ=$O(^IBD(359.3,"B",IBI,IBJ)) Q:'IBJ D
73 ..I $D(^IBD(359.3,IBJ,0)) S X=$$DEL("^IBD(359.3,",IBJ),IBCNT7=IBCNT7+1
74PURGELQ Q
75 ;
76STATCHK(ENTRY,IBHOW) ; -- Function
77 ; -- determine if entry in 357.96 can be deleted
78 ; Input : Entry := internal number of entry in 357.96
79 ; ibhow := 0,1,2, to delete none, complete, or all
80 ; Output: Okay := 1=okay to delete, 0=not okay
81 ;
82 N OKAY,STATUS
83 S OKAY=0
84 S IBHOW=+$G(IBHOW)
85 I IBHOW<1!(IBHOW>2) G STATQ ;How is none or not valid, don't delete
86 I '$D(^IBD(357.96,ENTRY,0)) G STATQ ;Entry doesn't exist
87 ;
88 ; -- if delete all, okay=1
89 I IBHOW=2,$P($G(^IBD(357.96,ENTRY,0)),"^",3) S OKAY=1 G STATQ
90 ;
91 ; -- if status = complete, piece 11 must equal 3, 4, or 12 to delete
92 S STATUS=$P($G(^IBD(357.96,ENTRY,0)),"^",11)
93 S OKAY=$S(STATUS=3:1,STATUS=4:1,STATUS=6:1,STATUS=7:1,STATUS=12:1,1:0)
94 ;
95STATQ Q OKAY
96 ;
97DEL(FILE,DA) ; -- Function
98 ; -- delete one entry
99 ; Input : File := internal file number of file or global root
100 ; da := internal number of entry, If more than DA
101 ; needs to be defined then pass da array by
102 ; reference
103 ; Output: 1 := succeded, 0 := failed
104 ;
105 N SUCCESS
106 S SUCCESS=0
107 I $G(FILE)=""!(+$G(DA)<1) G DELQ
108 S DIK=FILE D ^DIK
109 S SUCCESS=1
110 W:'$D(ZTQUEUED) !,"Entry number "_DA_" in file "_DIK_" Deleted!"
111DELQ Q SUCCESS
Note: See TracBrowser for help on using the repository browser.