1: DDSDFRM ;SFISC/MKO-DELETE A FORM ;09:12 AM 18 Aug 1994
2: ;;21.0;VA FileMan;;Dec 28, 1994
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: ;
27: EN(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: ;
46: INIT ;Setup
47: S DIOVRD=1
48: S DDSBLK=$NA(^TMP("DDSDFRM",$J,"BLK"))
49: K @DDSBLK
50: Q
51: ;
52: QUIT ;Cleanup
53: K @DDSBLK
54: K DDSBLK,DDSDEL,DDSFILE,DDSFORM,DDSQUIT
55: K DDH,DIRUT,DIROUT,DTOUT,DUOUT
56: Q
57: ;
58: FORM() ;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)
72: DICW ;;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: ;
75: FORMQ Q Y
76: ;
77: GETBLKS ;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: ;
90: DELPR ;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: ;
106: DELNPR ;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: ;
118: ASKDEL ;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: ;
143: ASKCONT ;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: ;
152: REPORT ;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: ;
166: COMMON(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
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DDSDFRM.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman / USER