DDSDBLK ;SFISC/MKO-DELETE UNUSED BLOCKS ;01:25 PM 11 Oct 1999
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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
EGP S DDS1=8108.1 D W^DICRW K DDS1 G:Y<0 FILEQ ;**CCO/NI 'PURGE UNUSED BLOCKS'
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSDBLK 3668 printed Dec 13, 2024@02:43:16 Page 2
DDSDBLK ;SFISC/MKO-DELETE UNUSED BLOCKS ;01:25 PM 11 Oct 1999
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 NEW %,D,DIAC,DIC,DIFILE,DIOVRD,X,Y
+8 DO INIT
+9 SET DDSFILE=$$FILE
if DDSFILE=-1
GOTO QUIT
+10 DO SUB(+DDSFILE,DDSSUB)
DO FINDB(DDSSUB,DDSBLK)
DO PROC
DO QUIT
+11 QUIT
+12 ;
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
EGP ;**CCO/NI 'PURGE UNUSED BLOCKS'
SET DDS1=8108.1
DO W^DICRW
KILL DDS1
if Y<0
GOTO FILEQ
+1 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
