freem_fileman/USER/DDSDEL.m - view

File: [Coherent Logic Development] / freem_fileman / USER / DDSDEL.m
Revision 1.1: download - view: text, annotated - select for diffs
Mon Apr 28 14:13:19 2025 UTC (3 months ago) by snw
Branches: MAIN
CVS tags: HEAD

Restructure repository

1: DDSDEL ;SFISC/MKO-DELETE FORMS FOR A FILE ;07:36 AM 2 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: FORM(DDSFILE,DDSECHO) ; 6: ;Delete all forms/blocks associated with file DDSFILE 7: N %,DIK,DIOVRD,DA,D0,X,Y 8: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU 9: S DIOVRD=1 10: D SETUP,GETFORMS(DDSFILE,DDSREF) 11: ; 12: ;Delete forms 13: W:DDSECHO !?3,"Deleting the FORMS..." 14: S DDSFRM="",DIK="^DIST(.403," 15: F S DDSFRM=$O(@DDSREF@("FRM",DDSFRM)) Q:'DDSFRM S DA=DDSFRM D ^DIK 16: K DIK,DA 17: ; 18: ;Delete blocks 19: W:DDSECHO !?3,"Deleting the BLOCKS..." 20: S DDSBLK="",DIK="^DIST(.404," 21: F S DDSBLK=$O(@DDSREF@("BLK",DDSBLK)) Q:'DDSBLK D 22: . S DDSLN=@DDSREF@("BLK",DDSBLK) 23: . S DDSBNAM=$P(DDSLN,U),DDSOFRM=$P(DDSLN,U,2),DDSPDD=$P(DDSLN,U,3) 24: . ; 25: . I DDSOFRM,DDSPDD D 26: .. I DDSECHO D 27: ... W !!?3,$C(7)_"*** Warning ***" 28: ... W !!?3,"Block "_DDSBNAM_" (#"_DDSBLK_")" 29: ... W !?3,"was deleted from the Block file." 30: ... W !!?3,"I'm deleting pointers to that block from" 31: .. S DDSFRM="" 32: .. F S DDSFRM=$O(@DDSREF@("BLK",DDSBLK,DDSFRM)) Q:'DDSFRM D 33: ... W:DDSECHO !?6,"Form "_$P(^DIST(.403,DDSFRM,0),U)_" (#"_DDSFRM_") ..." 34: ... D DELBLK(DDSBLK,DDSFRM) 35: .. W:DDSECHO !!?3,"The above form(s) need to be redesigned.",! 36: . ; 37: . E I 'DDSOFRM D 38: .. S DA=DDSBLK D ^DIK 39: ; 40: QUIT ;Cleanup and quit 41: K @DDSREF,DDSREF 42: K DDSBLK,DDSBNAM,DDSFRM,DDSOFRM,DDSLN,DDSPDD,DDSPG 43: Q 44: ; 45: SETUP ;Setup local variables 46: S:$D(DDSECHO)[0 DDSECHO=0 47: S DDSREF="^TMP(""DDSDEL"","_$J_")" 48: K @DDSREF 49: Q 50: ; 51: GETFORMS(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: ; 80: SETBLK(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: ; 87: DELBLK(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: ; 97: DD(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: ; 106: OTHER(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