Return to DDSDBLK.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    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