Routine: DDSDBLK

DDSDBLK ;SFISC/MKO-DELETE UNUSED BLOCKS ;09:15 AM  18 Aug 1994

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 N %,D,DIAC,DIC,DIFILE,DIOVRD,X,Y

 D INIT

 S DDSFILE=$$FILE G:DDSFILE=-1 QUIT

 D SUB(+DDSFILE,DDSSUB),FINDB(DDSSUB,DDSBLK),PROC,QUIT

ALL ;Purge all unused blocks regardless of file

 N %,DIC,DIOVRD,X,Y

 K DDSFILE

 D INIT,FINDALL(DDSBLK),PROC,QUIT

PROC ;Delete blocks in @DDSBLK

 I '$D(@DDSBLK) D  Q

 . W !!!,"There are no unused blocks associated with this file."

 D REPORT

 D ASKDEL Q:DDSQUIT

 D ASKCONT Q:DDSQUIT

 ;Delete blocks

 D:$G(DDSDEL) DELNPR

 D:'$G(DDSDEL) DELPR

 W !!,"DONE!"

INIT ;Initialize variables

 S (DDSDEL,DDSQUIT)=0,DIOVRD=1

 S DDSBLK=$NA(^TMP("DDSDBLK",$J,"BLK"))

 S DDSSUB=$NA(^TMP("DDSDBLK",$J,"SUB"))

 K @DDSBLK,@DDSSUB

QUIT ;Cleanup

 K @DDSBLK,@DDSSUB

 K DDSBLK,DDSDEL,DDSFILE,DDSQUIT,DDSSUB

 K DDH,DIRUT,DIROUT,DTOUT,DUOUT

FINDB(DDSSUB,DDSBLK) ;Find blocks associated with a specific file

 N B,B0,N

 S B=0 F  S B=$O(^DIST(.404,B)) Q:'B  S B0=$G(^(B,0)) D

 . S N=$P(B0,U,2)

 . I N,$D(@DDSSUB@(N)),'$D(^DIST(.403,"AB",B)),'$D(^DIST(.403,"AC",B)) S @DDSBLK@(B)=$P(B0,U)

FINDALL(DDSBLK) ;Find all unused blocks

 N B,B0

 S B=0 F  S B=$O(^DIST(.404,B)) Q:'B  S B0=$G(^(B,0)) D

 . I '$D(^DIST(.403,"AB",B)),'$D(^DIST(.403,"AC",B)) D

 .. S @DDSBLK@(B)=$P(B0,U)

FILE() ;Prompt for form

 ;Select file

 N DIC,Y

 S DDS1="PURGE UNUSED BLOCKS FROM" D W^DICRW K DDS1 G:Y<0 FILEQ

 S:'$D(@(DIC_"0)")) Y=-1

FILEQ Q Y

DELPR ;Delete blocks with prompting

 N DDSB

 W ! K DIK,DIR,DIRUT

 S DIR(0)="YA",DIR("B")="NO"

 S DIR("?")="  Enter 'Y' to delete, 'N' to keep."

 S DIK="^DIST(.404,"

 S DDSB=""

 F  S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT  D

 . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? "

 . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y

 . S DA=DDSB D ^DIK

 K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT

DELNPR ;Delete blocks without prompting

 N DDSB

 W ! K DIK

 S DIK="^DIST(.404,"

 S DDSB=""

 F  S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""  D

 . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..."

 . S DA=DDSB D ^DIK

 K DIK,DA

ASKDEL ;Ask if user wants to delete all unused blocks w/o confirmation

 W ! S DIR(0)="YA",DIR("B")="NO"

 S DIR("A",1)=""

 S DIR("A")="Delete all unused blocks without prompting (Y/N)? "

 S DIR("?",1)="  Enter 'Y' to delete unused blocks from the BLOCK file"

 S DIR("?",2)="    without confirmation."

 S DIR("?",3)=""

 S DIR("?")="  Enter 'N' to confirm each delete."

 D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q

 S DDSDEL=Y

ASKCONT ;Final chance to abort

 K DIR S DIR(0)="YA",DIR("B")="NO"

 S DIR("A",1)=""

 S DIR("A")="Continue (Y/N)? "

 S DIR("?")="  Enter 'Y' to delete form.  Enter 'N' to exit."

 D ^DIR K DIR

 S:$D(DIRUT)!'Y DDSQUIT=1

REPORT ;Print report

N B

 W !!!

 W "  UNUSED BLOCKS"

 W:$D(DDSFILE) " ASSOCIATED WITH FILE "_$P(DDSFILE,U,2)_" (#"_$P(DDSFILE,U)_")"

 W !!,"  Internal"

 W !,"  Entry Number   Block Name"

 W !,"  ------------   ----------"

 S B="" F  S B=$O(@DDSBLK@(B)) Q:B=""  W !,"  "_B,?17,@DDSBLK@(B)

SUB(FN,OUT) ;

 ;Set OUT array for file number FN and all its subfiles

 N SUB

 I $D(^DD(FN)) S @OUT@(FN)=""

 S SUB="" F  S SUB=$O(^DD(FN,"SB",SUB)) Q:SUB=""  D SUB(SUB,OUT)

DDSDBLK   ;SFISC/MKO-DELETE UNUSED BLOCKS ;09:15 AM  18 Aug 1994

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4        NEW %,D,DIAC,DIC,DIFILE,DIOVRD,X,Y

 +5        DO INIT

 +6        SET DDSFILE=$$FILE

           IF DDSFILE=-1

               GOTO QUIT

 +7        DO SUB(+DDSFILE,DDSSUB)

           DO FINDB(DDSSUB,DDSBLK)

           DO PROC

           DO QUIT

 +8        QUIT

 +9       ;

ALL       ;Purge all unused blocks regardless of file

 +1        NEW %,DIC,DIOVRD,X,Y

 +2        KILL DDSFILE

 +3        DO INIT

           DO FINDALL(DDSBLK)

           DO PROC

           DO QUIT

 +4        QUIT

 +5       ;

PROC      ;Delete blocks in @DDSBLK

 +1        IF '$DATA(@DDSBLK)

               Begin DoDot:1

 +2                WRITE !!!,"There are no unused blocks associated with this file."

               End DoDot:1

               QUIT

 +3       ;

 +4        DO REPORT

 +5        DO ASKDEL

           IF DDSQUIT

               QUIT

 +6        DO ASKCONT

           IF DDSQUIT

               QUIT

 +7       ;

 +8       ;Delete blocks

 +9        IF $GET(DDSDEL)

               DO DELNPR

 +10       IF '$GET(DDSDEL)

               DO DELPR

 +11       WRITE !!,"DONE!"

 +12       QUIT

 +13      ;

INIT      ;Initialize variables

 +1        SET (DDSDEL,DDSQUIT)=0

           SET DIOVRD=1

 +2        SET DDSBLK=$NAME(^TMP("DDSDBLK",$JOB,"BLK"))

 +3        SET DDSSUB=$NAME(^TMP("DDSDBLK",$JOB,"SUB"))

 +4        KILL @DDSBLK,@DDSSUB

 +5        QUIT

 +6       ;

QUIT      ;Cleanup

 +1        KILL @DDSBLK,@DDSSUB

 +2        KILL DDSBLK,DDSDEL,DDSFILE,DDSQUIT,DDSSUB

 +3        KILL DDH,DIRUT,DIROUT,DTOUT,DUOUT

 +4        QUIT

 +5       ;

FINDB(DDSSUB,DDSBLK) ;Find blocks associated with a specific file

 +1        NEW B,B0,N

 +2        SET B=0

FOR

               SET B=$ORDER(^DIST(.404,B))

               IF 'B

                   QUIT

               SET B0=$GET(^(B,0))

               Begin DoDot:1

 +3                SET N=$PIECE(B0,U,2)

 +4                IF N

                       IF $DATA(@DDSSUB@(N))

                           IF '$DATA(^DIST(.403,"AB",B))

                               IF '$DATA(^DIST(.403,"AC",B))

                                   SET @DDSBLK@(B)=$PIECE(B0,U)

               End DoDot:1

 +5        QUIT

 +6       ;

FINDALL(DDSBLK) ;Find all unused blocks

 +1        NEW B,B0

 +2        SET B=0

FOR

               SET B=$ORDER(^DIST(.404,B))

               IF 'B

                   QUIT

               SET B0=$GET(^(B,0))

               Begin DoDot:1

 +3                IF '$DATA(^DIST(.403,"AB",B))

                       IF '$DATA(^DIST(.403,"AC",B))

                           Begin DoDot:2

 +4                            SET @DDSBLK@(B)=$PIECE(B0,U)

                           End DoDot:2

               End DoDot:1

 +5        QUIT

 +6       ;

FILE()    ;Prompt for form

 +1       ;Select file

 +2        NEW DIC,Y

 +3        SET DDS1="PURGE UNUSED BLOCKS FROM"

           DO W^DICRW

           KILL DDS1

           IF Y<0

               GOTO FILEQ

 +4        IF '$DATA(@(DIC_"0)"))

               SET Y=-1

FILEQ      QUIT Y

 +1       ;

DELPR     ;Delete blocks with prompting

 +1        NEW DDSB

 +2        WRITE !

           KILL DIK,DIR,DIRUT

 +3        SET DIR(0)="YA"

           SET DIR("B")="NO"

 +4        SET DIR("?")="  Enter 'Y' to delete, 'N' to keep."

 +5        SET DIK="^DIST(.404,"

 +6       ;

 +7        SET DDSB=""

 +8        FOR

               SET DDSB=$ORDER(@DDSBLK@(DDSB))

               IF DDSB=""!DDSQUIT

                   QUIT

               Begin DoDot:1

 +9                SET DIR("A")=$PIECE(@DDSBLK@(DDSB),U)_$JUSTIFY("",30-$LENGTH($PIECE(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? "

 +10               DO ^DIR

                   IF $DATA(DIRUT)

                       SET DDSQUIT=1

                   IF 'Y

                       QUIT

 +11               SET DA=DDSB

                   DO ^DIK

               End DoDot:1

 +12       KILL DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT

 +13       QUIT

 +14      ;

DELNPR    ;Delete blocks without prompting

 +1        NEW DDSB

 +2        WRITE !

           KILL DIK

 +3        SET DIK="^DIST(.404,"

 +4        SET DDSB=""

 +5        FOR

               SET DDSB=$ORDER(@DDSBLK@(DDSB))

               IF DDSB=""

                   QUIT

               Begin DoDot:1

 +6                WRITE !,"Deleting block "_$PIECE(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..."

 +7                SET DA=DDSB

                   DO ^DIK

               End DoDot:1

 +8        KILL DIK,DA

 +9        QUIT

 +10      ;

ASKDEL    ;Ask if user wants to delete all unused blocks w/o confirmation

 +1        WRITE !

           SET DIR(0)="YA"

           SET DIR("B")="NO"

 +2        SET DIR("A",1)=""

 +3        SET DIR("A")="Delete all unused blocks without prompting (Y/N)? "

 +4        SET DIR("?",1)="  Enter 'Y' to delete unused blocks from the BLOCK file"

 +5        SET DIR("?",2)="    without confirmation."

 +6        SET DIR("?",3)=""

 +7        SET DIR("?")="  Enter 'N' to confirm each delete."

 +8        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               SET DDSQUIT=1

               QUIT

 +9        SET DDSDEL=Y

 +10       QUIT

 +11      ;

ASKCONT   ;Final chance to abort

 +1        KILL DIR

           SET DIR(0)="YA"

           SET DIR("B")="NO"

 +2        SET DIR("A",1)=""

 +3        SET DIR("A")="Continue (Y/N)? "

 +4        SET DIR("?")="  Enter 'Y' to delete form.  Enter 'N' to exit."

 +5        DO ^DIR

           KILL DIR

 +6        IF $DATA(DIRUT)!'Y

               SET DDSQUIT=1

 +7        QUIT

 +8       ;

REPORT    ;Print report

 +1        NEW B

 +2        WRITE !!!

 +3        WRITE "  UNUSED BLOCKS"

 +4        IF $DATA(DDSFILE)

               WRITE " ASSOCIATED WITH FILE "_$PIECE(DDSFILE,U,2)_" (#"_$PIECE(DDSFILE,U)_")"

 +5        WRITE !!,"  Internal"

 +6        WRITE !,"  Entry Number   Block Name"

 +7        WRITE !,"  ------------   ----------"

 +8       ;

 +9        SET B=""

FOR

               SET B=$ORDER(@DDSBLK@(B))

               IF B=""

                   QUIT

               WRITE !,"  "_B,?17,@DDSBLK@(B)

 +10       QUIT

 +11      ;

SUB(FN,OUT) ;

 +1       ;Set OUT array for file number FN and all its subfiles

 +2        NEW SUB

 +3        IF $DATA(^DD(FN))

               SET @OUT@(FN)=""

 +4        SET SUB=""

FOR

               SET SUB=$ORDER(^DD(FN,"SB",SUB))

               IF SUB=""

                   QUIT

               DO SUB(SUB,OUT)

 +5        QUIT

DDSDBLK.m