Return to DDSDBLK.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DDSDBLK.m, revision 1.1

1.1     ! snw         1: DDSDBLK        ;SFISC/MKO-DELETE UNUSED BLOCKS ;09:15 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 %,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:        ;
        !            11: ALL    ;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:        ;
        !            17: PROC   ;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:        ;
        !            31: INIT   ;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:        ;
        !            38: QUIT   ;Cleanup
        !            39:        K @DDSBLK,@DDSSUB
        !            40:        K DDSBLK,DDSDEL,DDSFILE,DDSQUIT,DDSSUB
        !            41:        K DDH,DIRUT,DIROUT,DTOUT,DUOUT
        !            42:        Q
        !            43:        ;
        !            44: FINDB(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:        ;
        !            51: FINDALL(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:        ;
        !            58: FILE() ;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
        !            63: FILEQ  Q Y
        !            64:        ;
        !            65: DELPR  ;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:        ;
        !            80: DELNPR ;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:        ;
        !            91: ASKDEL ;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:        ;
        !           103: ASKCONT        ;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:        ;
        !           112: REPORT ;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:        ;
        !           124: SUB(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