source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDSDBLK.m@ 1582

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

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1DDSDBLK ;SFISC/MKO-DELETE UNUSED BLOCKS ;09:15 AM 18 Aug 1994
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 N %,D,DIAC,DIC,DIFILE,DIOVRD,X,Y
6 D INIT
7 S DDSFILE=$$FILE G:DDSFILE=-1 QUIT
8 D SUB(+DDSFILE,DDSSUB),FINDB(DDSSUB,DDSBLK),PROC,QUIT
9 Q
10 ;
11ALL ;Purge all unused blocks regardless of file
12 N %,DIC,DIOVRD,X,Y
13 K DDSFILE
14 D INIT,FINDALL(DDSBLK),PROC,QUIT
15 Q
16 ;
17PROC ;Delete blocks in @DDSBLK
18 I '$D(@DDSBLK) D Q
19 . W !!!,"There are no unused blocks associated with this file."
20 ;
21 D REPORT
22 D ASKDEL Q:DDSQUIT
23 D ASKCONT Q:DDSQUIT
24 ;
25 ;Delete blocks
26 D:$G(DDSDEL) DELNPR
27 D:'$G(DDSDEL) DELPR
28 W !!,"DONE!"
29 Q
30 ;
31INIT ;Initialize variables
32 S (DDSDEL,DDSQUIT)=0,DIOVRD=1
33 S DDSBLK=$NA(^TMP("DDSDBLK",$J,"BLK"))
34 S DDSSUB=$NA(^TMP("DDSDBLK",$J,"SUB"))
35 K @DDSBLK,@DDSSUB
36 Q
37 ;
38QUIT ;Cleanup
39 K @DDSBLK,@DDSSUB
40 K DDSBLK,DDSDEL,DDSFILE,DDSQUIT,DDSSUB
41 K DDH,DIRUT,DIROUT,DTOUT,DUOUT
42 Q
43 ;
44FINDB(DDSSUB,DDSBLK) ;Find blocks associated with a specific file
45 N B,B0,N
46 S B=0 F S B=$O(^DIST(.404,B)) Q:'B S B0=$G(^(B,0)) D
47 . S N=$P(B0,U,2)
48 . I N,$D(@DDSSUB@(N)),'$D(^DIST(.403,"AB",B)),'$D(^DIST(.403,"AC",B)) S @DDSBLK@(B)=$P(B0,U)
49 Q
50 ;
51FINDALL(DDSBLK) ;Find all unused blocks
52 N B,B0
53 S B=0 F S B=$O(^DIST(.404,B)) Q:'B S B0=$G(^(B,0)) D
54 . I '$D(^DIST(.403,"AB",B)),'$D(^DIST(.403,"AC",B)) D
55 .. S @DDSBLK@(B)=$P(B0,U)
56 Q
57 ;
58FILE() ;Prompt for form
59 ;Select file
60 N DIC,Y
61 S DDS1="PURGE UNUSED BLOCKS FROM" D W^DICRW K DDS1 G:Y<0 FILEQ
62 S:'$D(@(DIC_"0)")) Y=-1
63FILEQ Q Y
64 ;
65DELPR ;Delete blocks with prompting
66 N DDSB
67 W ! K DIK,DIR,DIRUT
68 S DIR(0)="YA",DIR("B")="NO"
69 S DIR("?")=" Enter 'Y' to delete, 'N' to keep."
70 S DIK="^DIST(.404,"
71 ;
72 S DDSB=""
73 F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT D
74 . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? "
75 . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y
76 . S DA=DDSB D ^DIK
77 K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT
78 Q
79 ;
80DELNPR ;Delete blocks without prompting
81 N DDSB
82 W ! K DIK
83 S DIK="^DIST(.404,"
84 S DDSB=""
85 F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D
86 . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..."
87 . S DA=DDSB D ^DIK
88 K DIK,DA
89 Q
90 ;
91ASKDEL ;Ask if user wants to delete all unused blocks w/o confirmation
92 W ! S DIR(0)="YA",DIR("B")="NO"
93 S DIR("A",1)=""
94 S DIR("A")="Delete all unused blocks without prompting (Y/N)? "
95 S DIR("?",1)=" Enter 'Y' to delete unused blocks from the BLOCK file"
96 S DIR("?",2)=" without confirmation."
97 S DIR("?",3)=""
98 S DIR("?")=" Enter 'N' to confirm each delete."
99 D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
100 S DDSDEL=Y
101 Q
102 ;
103ASKCONT ;Final chance to abort
104 K DIR S DIR(0)="YA",DIR("B")="NO"
105 S DIR("A",1)=""
106 S DIR("A")="Continue (Y/N)? "
107 S DIR("?")=" Enter 'Y' to delete form. Enter 'N' to exit."
108 D ^DIR K DIR
109 S:$D(DIRUT)!'Y DDSQUIT=1
110 Q
111 ;
112REPORT ;Print report
113 N B
114 W !!!
115 W " UNUSED BLOCKS"
116 W:$D(DDSFILE) " ASSOCIATED WITH FILE "_$P(DDSFILE,U,2)_" (#"_$P(DDSFILE,U)_")"
117 W !!," Internal"
118 W !," Entry Number Block Name"
119 W !," ------------ ----------"
120 ;
121 S B="" F S B=$O(@DDSBLK@(B)) Q:B="" W !," "_B,?17,@DDSBLK@(B)
122 Q
123 ;
124SUB(FN,OUT) ;
125 ;Set OUT array for file number FN and all its subfiles
126 N SUB
127 I $D(^DD(FN)) S @OUT@(FN)=""
128 S SUB="" F S SUB=$O(^DD(FN,"SB",SUB)) Q:SUB="" D SUB(SUB,OUT)
129 Q
Note: See TracBrowser for help on using the repository browser.