source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDSDEL.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.4 KB
Line 
1DDSDEL ;SFISC/MKO-DELETE FORMS FOR A FILE ;3:06 PM 2 Nov 1998
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5FORM(DDSFILE,DDSECHO) ;
6 ;Delete all forms/blocks associated with file DDSFILE
7 N DDSREF,DDSBLK,DDSBNAM,DDSFRM,DDSOFRM,DDSLN,DDSPDD,DDSPG
8 N %,DIK,DIOVRD,DA,D0,X,Y
9 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
10 S DIOVRD=1
11 D SETUP,GETFORMS(DDSFILE,DDSREF)
12 ;
13 ;Delete forms
14 W:DDSECHO !?3,"Deleting the FORMS..."
15 S DDSFRM="",DIK="^DIST(.403,"
16 F S DDSFRM=$O(@DDSREF@("FRM",DDSFRM)) Q:'DDSFRM S DA=DDSFRM D ^DIK
17 K DIK,DA
18 ;
19 ;Delete blocks
20 W:DDSECHO !?3,"Deleting the BLOCKS..."
21 S DDSBLK="",DIK="^DIST(.404,"
22 F S DDSBLK=$O(@DDSREF@("BLK",DDSBLK)) Q:'DDSBLK D
23 . S DDSLN=@DDSREF@("BLK",DDSBLK)
24 . S DDSBNAM=$P(DDSLN,U),DDSOFRM=$P(DDSLN,U,2),DDSPDD=$P(DDSLN,U,3)
25 . ;
26 . I DDSOFRM,DDSPDD D
27 .. I DDSECHO D
28 ... W !!?3,$C(7)_"*** Warning ***"
29 ... W !!?3,"Block "_DDSBNAM_" (#"_DDSBLK_")"
30 ... W !?3,"was deleted from the Block file."
31 ... W !!?3,"I'm deleting pointers to that block from"
32 .. S DDSFRM=""
33 .. F S DDSFRM=$O(@DDSREF@("BLK",DDSBLK,DDSFRM)) Q:'DDSFRM D
34 ... W:DDSECHO !?6,"Form "_$P(^DIST(.403,DDSFRM,0),U)_" (#"_DDSFRM_") ..."
35 ... D DELBLK(DDSBLK,DDSFRM)
36 .. W:DDSECHO !!?3,"The above form(s) need to be redesigned.",!
37 . ;
38 . E I 'DDSOFRM D
39 .. S DA=DDSBLK D ^DIK
40 ;
41QUIT ;Cleanup and quit
42 K @DDSREF
43 Q
44 ;
45SETUP ;Setup local variables
46 S:$D(DDSECHO)[0 DDSECHO=0
47 S DDSREF="^TMP(""DDSDEL"","_$J_")"
48 K @DDSREF
49 Q
50 ;
51GETFORMS(FILE,REF) ;
52 ;Get all forms and blocks associated with file number FILE
53 ;and all subfiles associated with FILE
54 ;Put results in
55 ; @REF@("DD",file#) = null
56 ; ("FRM",form#) = form name
57 ; ("BLK",block#) = block name^used on forms not being
58 ; deleted^dd of block is being deleted
59 ; ("BLK",block#,form#) = null for all blocks that are found
60 ; on a form not being deleted
61 ;
62 N B,F,P,FNAM
63 ;Get DDs of file and subfiles
64 D DD(FILE,REF)
65 ;
66 ;Get all forms associated with file
67 S FNAM="" F S FNAM=$O(^DIST(.403,"F"_FILE,FNAM)) Q:FNAM="" D
68 . S F="" F S F=$O(^DIST(.403,"F"_FILE,FNAM,F)) Q:F="" D
69 .. Q:$D(^DIST(.403,F,0))[0
70 .. S @REF@("FRM",F)=$P(^DIST(.403,F,0),U)
71 ;
72 ;Get all blocks associated with each form
73 S F="" F S F=$O(@REF@("FRM",F)) Q:F="" D
74 . S P=0 F S P=$O(^DIST(.403,F,40,P)) Q:'P D
75 .. S B=$P($G(^DIST(.403,F,40,P,0)),U,2)
76 .. I B D SETBLK(B,REF)
77 .. S B=0 F S B=$O(^DIST(.403,F,40,P,40,B)) Q:'B D SETBLK(B,REF)
78 Q
79 ;
80SETBLK(B,REF) ;
81 ;Put block info into @REF
82 N B0
83 S B0=$G(^DIST(.404,B,0)) Q:B0?."^"
84 S @REF@("BLK",B)=$P(B0,U)_U_$$OTHER(B,REF)_U_($D(@REF@("DD",+$P(B0,U,2)))#2)
85 Q
86 ;
87DELBLK(DDSBLK,DDSFRM) ;
88 ;Delete block DDSBLK from form DDSFRM
89 N DIK,DA,D0
90 S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSFRM,40,DDSPG)) Q:'DDSPG D
91 . I $D(^DIST(.403,DDSFRM,40,DDSPG,40,"B",DDSBLK)) D
92 .. S DIK="^DIST(.403,"_DDSFRM_",40,"_DDSPG_",40,"
93 .. S DA(2)=DDSFRM,DA(1)=DDSPG,DA=DDSBLK
94 .. D ^DIK
95 Q
96 ;
97DD(F,REF,K) ;
98 ;Put file # and all its subfile #s into array @REF@("DD")
99 ;Kill REF first if $G(K)=""
100 N SB
101 K:$G(K)="" @REF@("DD")
102 S @REF@("DD",F)=""
103 S SB="" F S SB=$O(^DD(F,"SB",SB)) Q:SB="" D DD(SB,REF,1)
104 Q
105 ;
106OTHER(B,REF) ;
107 ;Is block B found on forms other than what's in @REF@("FRM",F)=""
108 ;If so, put form numbers in @REF@("BLK",B,F)
109 N F,O,C
110 S O=0,F=""
111 F C="AB","AC" F S F=$O(^DIST(.403,C,B,F)) Q:F="" D
112 . I $D(@REF@("FRM",F))[0 S O=1,@REF@("BLK",B,F)=""
113 Q O
Note: See TracBrowser for help on using the repository browser.