source: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDSDBLK.m@ 628

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
 Q
 ;
ALL ;Purge all unused blocks regardless of file
 N %,DIC,DIOVRD,X,Y
 K DDSFILE
 D INIT,FINDALL(DDSBLK),PROC,QUIT
 Q
 ;
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!"
 Q
 ;
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
 Q
 ;
QUIT ;Cleanup
 K @DDSBLK,@DDSSUB
 K DDSBLK,DDSDEL,DDSFILE,DDSQUIT,DDSSUB
 K DDH,DIRUT,DIROUT,DTOUT,DUOUT
 Q
 ;
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)
 Q
 ;
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)
 Q
 ;
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
 Q
 ;
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
 Q
 ;
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
 Q
 ;
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
 Q
 ;
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)
 Q
 ;
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)
 Q