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

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

initial load of WorldVistAEHR
File size: 4.7 KB
RevLine 
[613]1DDSDFRM ;SFISC/MKO-DELETE A FORM ;09:12 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 %,DIC,DIOVRD,X,Y
6 D INIT
7 S (DDSDEL,DDSQUIT)=0
8 ;
9 S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
10 ;
11 D GETBLKS
12 D REPORT
13 I $D(@DDSBLK) D ASKDEL G:DDSQUIT QUIT
14 D ASKCONT G:DDSQUIT QUIT
15 ;
16 ;Delete form
17 W !!,"Deleting form "_$P(DDSFORM,U,2)_" (IEN #"_+DDSFORM_") ..."
18 S DIK="^DIST(.403,",DA=+DDSFORM
19 D ^DIK K DIK,DA
20 ;
21 ;Delete blocks
22 I DDSDEL D:'$G(DDSDEL(1)) DELPR D:$G(DDSDEL(1)) DELNPR
23 W !!,"DONE!"
24 D QUIT
25 Q
26 ;
27EN(DDSFORM) ;Delete form number DDSFORM
28 N %,DA,DDSB,DDSBLK,DIC,DIK,DIOVRD,X,Y
29 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
30 D INIT
31 D GETBLKS
32 ;
33 ;Delete form
34 S DIK="^DIST(.403,",DA=+DDSFORM
35 D ^DIK K DIK,DA
36 ;
37 ;Delete blocks
38 S DIK="^DIST(.404,"
39 S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D
40 . Q:$P(@DDSBLK@(DDSB),U,2)
41 . S DA=DDSB D ^DIK
42 ;
43 K @DDSBLK
44 Q
45 ;
46INIT ;Setup
47 S DIOVRD=1
48 S DDSBLK=$NA(^TMP("DDSDFRM",$J,"BLK"))
49 K @DDSBLK
50 Q
51 ;
52QUIT ;Cleanup
53 K @DDSBLK
54 K DDSBLK,DDSDEL,DDSFILE,DDSFORM,DDSQUIT
55 K DDH,DIRUT,DIROUT,DTOUT,DUOUT
56 Q
57 ;
58FORM() ;Prompt for form
59 ;Select file
60 N D,DIC
61 S DDS1="DELETE FORM FROM" D W^DICRW K DDS1 G:Y<0 FORMQ
62 I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
63 S DDSFILE=Y
64 ;
65 ;Select form
66 W ! K DIC
67 S DIC="^DIST(.403,",DIC(0)="QEAM"
68 S DIC(0)="QEA",D="F"_+DDSFILE
69 S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
70 S DIC("A")="Select FORM to delete: "
71 S DIC("W")=$P($T(DICW),";",3,999)
72DICW ;;N %G,%Y S %Y=Y,%G=^(0) W:$X>35 ! W ?35,"#"_Y S Y=$P(%G,U,5) W:Y]"" ?43," "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y S Y=%Y
73 D IX^DIC
74 ;
75FORMQ Q Y
76 ;
77GETBLKS ;Get all blocks on form
78 ; @DDSBLK@(bk#)=Block name^flag (1=used on other forms)
79 ;
80 N P,B
81 S P=0 F S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P D
82 . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
83 . I B]"",'$D(@DDSBLK@(B)) D
84 .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
85 . S B=0
86 . F S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B D:'$D(@DDSBLK@(B))
87 .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
88 Q
89 ;
90DELPR ;Delete blocks with prompting
91 N DDSB
92 W ! K DIK,DIR,DIRUT
93 S DIR(0)="YA",DIR("B")="NO"
94 S DIR("?")=" Enter 'Y' to delete, 'N' to keep."
95 S DIK="^DIST(.404,"
96 ;
97 S DDSB=""
98 F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT D
99 . Q:$P(@DDSBLK@(DDSB),U,2)
100 . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? "
101 . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y
102 . S DA=DDSB D ^DIK
103 K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT
104 Q
105 ;
106DELNPR ;Delete blocks without prompting
107 N DDSB
108 W ! K DIK
109 S DIK="^DIST(.404,"
110 S DDSB=""
111 F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D
112 . Q:$P(@DDSBLK@(DDSB),U,2)
113 . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..."
114 . S DA=DDSB D ^DIK
115 K DIK,DA
116 Q
117 ;
118ASKDEL ;Ask if user wants to delete all the blocks on this form
119 K DIR W ! S DIR(0)="YA",DIR("B")="YES"
120 S DIR("A",1)=""
121 S DIR("A",2)="Delete all deletable blocks used on form "_$P(DDSFORM,U,2)
122 S DIR("A")="from the BLOCK file (Y/N)? "
123 S DIR("?",1)=" Enter 'Y' to delete blocks used on form"
124 S DIR("?",2)=" "_$P(DDSFORM,U,2)_" from the BLOCK file."
125 S DIR("?",3)=" (Only blocks not used on other forms can be deleted.)"
126 S DIR("?",4)=""
127 S DIR("?")=" Enter 'N' to delete the form but not the blocks."
128 D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
129 S DDSDEL=Y Q:'DDSDEL
130 ;
131 ;Ask if user wants to delete without prompting
132 W ! S DIR(0)="YA",DIR("B")="NO"
133 S DIR("A",1)=""
134 S DIR("A")="Delete blocks without prompting (Y/N)? "
135 S DIR("?",1)=" Enter 'Y' to delete blocks from the BLOCK file"
136 S DIR("?",2)=" without confirmation."
137 S DIR("?",3)=""
138 S DIR("?")=" Enter 'N' to confirm each delete."
139 D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
140 S DDSDEL(1)=Y
141 Q
142 ;
143ASKCONT ;Final chance to abort
144 K DIR S DIR(0)="YA",DIR("B")="NO"
145 S DIR("A",1)=""
146 S DIR("A")="Continue (Y/N)? "
147 S DIR("?")=" Enter 'Y' to delete form. Enter 'N' to exit."
148 D ^DIR K DIR
149 S:$D(DIRUT)!'Y DDSQUIT=1
150 Q
151 ;
152REPORT ;Print report
153 N B
154 W !!! I '$D(@DDSBLK) W "There are no blocks on this form." Q
155 W " BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
156 W !!," Internal",?50,"Used on"
157 W !," Entry Number Block Name",?50,"Other Forms? Deletable?"
158 W !," ------------ ----------",?50,"------------ ----------"
159 ;
160 S B="" F S B=$O(@DDSBLK@(B)) Q:B="" D
161 . W !," "_B,?17,$P(@DDSBLK@(B),U),?54
162 . W $S($P(@DDSBLK@(B),U,2):"YES",1:"NO")
163 . W ?68,$S($P(@DDSBLK@(B),U,2):"NO",1:"YES")
164 Q
165 ;
166COMMON(B,F) ;Is block B found on forms other than F
167 N C,F1
168 S C=0,F1=""
169 F S F1=$O(^DIST(.403,"AB",B,F1)) Q:F1="" I F1'=F S C=1 Q
170 I 'C S F1="" F S F1=$O(^DIST(.403,"AC",B,F1)) Q:F1="" I F1'=F S C=1 Q
171 Q C
Note: See TracBrowser for help on using the repository browser.