Return to DDSDBLK.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DDSDBLK.m, revision 1.1.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