DDSDFRM ;SFISC/MKO-DELETE A FORM ;09:12 AM 18 Aug 1994
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
N %,DIC,DIOVRD,X,Y
D INIT
S (DDSDEL,DDSQUIT)=0
;
S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
;
D GETBLKS
D REPORT
I $D(@DDSBLK) D ASKDEL G:DDSQUIT QUIT
D ASKCONT G:DDSQUIT QUIT
;
;Delete form
W !!,"Deleting form "_$P(DDSFORM,U,2)_" (IEN #"_+DDSFORM_") ..."
S DIK="^DIST(.403,",DA=+DDSFORM
D ^DIK K DIK,DA
;
;Delete blocks
I DDSDEL D:'$G(DDSDEL(1)) DELPR D:$G(DDSDEL(1)) DELNPR
W !!,"DONE!"
D QUIT
Q
;
EN(DDSFORM) ;Delete form number DDSFORM
N %,DA,DDSB,DDSBLK,DIC,DIK,DIOVRD,X,Y
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
D INIT
D GETBLKS
;
;Delete form
S DIK="^DIST(.403,",DA=+DDSFORM
D ^DIK K DIK,DA
;
;Delete blocks
S DIK="^DIST(.404,"
S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D
. Q:$P(@DDSBLK@(DDSB),U,2)
. S DA=DDSB D ^DIK
;
K @DDSBLK
Q
;
INIT ;Setup
S DIOVRD=1
S DDSBLK=$NA(^TMP("DDSDFRM",$J,"BLK"))
K @DDSBLK
Q
;
QUIT ;Cleanup
K @DDSBLK
K DDSBLK,DDSDEL,DDSFILE,DDSFORM,DDSQUIT
K DDH,DIRUT,DIROUT,DTOUT,DUOUT
Q
;
FORM() ;Prompt for form
;Select file
N D,DIC
S DDS1="DELETE FORM FROM" D W^DICRW K DDS1 G:Y<0 FORMQ
I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
S DDSFILE=Y
;
;Select form
W ! K DIC
S DIC="^DIST(.403,",DIC(0)="QEAM"
S DIC(0)="QEA",D="F"_+DDSFILE
S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
S DIC("A")="Select FORM to delete: "
S DIC("W")=$P($T(DICW),";",3,999)
DICW ;;N %G,%Y S %Y=Y,%G=^(0) W:$X>35 ! W ?35,"#"_Y S Y=$P(%G,U,5) W:Y]"" ?43," "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y S Y=%Y
D IX^DIC
;
FORMQ Q Y
;
GETBLKS ;Get all blocks on form
; @DDSBLK@(bk#)=Block name^flag (1=used on other forms)
;
N P,B
S P=0 F S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P D
. S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
. I B]"",'$D(@DDSBLK@(B)) D
.. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
. S B=0
. F S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B D:'$D(@DDSBLK@(B))
.. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
Q
;
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
. Q:$P(@DDSBLK@(DDSB),U,2)
. 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
. Q:$P(@DDSBLK@(DDSB),U,2)
. 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 the blocks on this form
K DIR W ! S DIR(0)="YA",DIR("B")="YES"
S DIR("A",1)=""
S DIR("A",2)="Delete all deletable blocks used on form "_$P(DDSFORM,U,2)
S DIR("A")="from the BLOCK file (Y/N)? "
S DIR("?",1)=" Enter 'Y' to delete blocks used on form"
S DIR("?",2)=" "_$P(DDSFORM,U,2)_" from the BLOCK file."
S DIR("?",3)=" (Only blocks not used on other forms can be deleted.)"
S DIR("?",4)=""
S DIR("?")=" Enter 'N' to delete the form but not the blocks."
D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
S DDSDEL=Y Q:'DDSDEL
;
;Ask if user wants to delete without prompting
W ! S DIR(0)="YA",DIR("B")="NO"
S DIR("A",1)=""
S DIR("A")="Delete blocks without prompting (Y/N)? "
S DIR("?",1)=" Enter 'Y' to delete 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(1)=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 !!! I '$D(@DDSBLK) W "There are no blocks on this form." Q
W " BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
W !!," Internal",?50,"Used on"
W !," Entry Number Block Name",?50,"Other Forms? Deletable?"
W !," ------------ ----------",?50,"------------ ----------"
;
S B="" F S B=$O(@DDSBLK@(B)) Q:B="" D
. W !," "_B,?17,$P(@DDSBLK@(B),U),?54
. W $S($P(@DDSBLK@(B),U,2):"YES",1:"NO")
. W ?68,$S($P(@DDSBLK@(B),U,2):"NO",1:"YES")
Q
;
COMMON(B,F) ;Is block B found on forms other than F
N C,F1
S C=0,F1=""
F S F1=$O(^DIST(.403,"AB",B,F1)) Q:F1="" I F1'=F S C=1 Q
I 'C S F1="" F S F1=$O(^DIST(.403,"AC",B,F1)) Q:F1="" I F1'=F S C=1 Q
Q C
DDSDFRM ;SFISC/MKO-DELETE A FORM ;09:12 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 %,DIC,DIOVRD,X,Y
+5 DO INIT
+6 SET (DDSDEL,DDSQUIT)=0
+7 ;
+8 SET DDSFORM=$$FORM
IF DDSFORM=-1
GOTO QUIT
+9 ;
+10 DO GETBLKS
+11 DO REPORT
+12 IF $DATA(@DDSBLK)
DO ASKDEL
IF DDSQUIT
GOTO QUIT
+13 DO ASKCONT
IF DDSQUIT
GOTO QUIT
+14 ;
+15 ;Delete form
+16 WRITE !!,"Deleting form "_$PIECE(DDSFORM,U,2)_" (IEN #"_+DDSFORM_") ..."
+17 SET DIK="^DIST(.403,"
SET DA=+DDSFORM
+18 DO ^DIK
KILL DIK,DA
+19 ;
+20 ;Delete blocks
+21 IF DDSDEL
IF '$GET(DDSDEL(1))
DO DELPR
IF $GET(DDSDEL(1))
DO DELNPR
+22 WRITE !!,"DONE!"
+23 DO QUIT
+24 QUIT
+25 ;
EN(DDSFORM) ;Delete form number DDSFORM
+1 NEW %,DA,DDSB,DDSBLK,DIC,DIK,DIOVRD,X,Y
+2 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+3 DO INIT
+4 DO GETBLKS
+5 ;
+6 ;Delete form
+7 SET DIK="^DIST(.403,"
SET DA=+DDSFORM
+8 DO ^DIK
KILL DIK,DA
+9 ;
+10 ;Delete blocks
+11 SET DIK="^DIST(.404,"
+12 SET DDSB=""
FOR
SET DDSB=$ORDER(@DDSBLK@(DDSB))
IF DDSB=""
QUIT
Begin DoDot:1
+13 IF $PIECE(@DDSBLK@(DDSB),U,2)
QUIT
+14 SET DA=DDSB
DO ^DIK
End DoDot:1
+15 ;
+16 KILL @DDSBLK
+17 QUIT
+18 ;
INIT ;Setup
+1 SET DIOVRD=1
+2 SET DDSBLK=$NAME(^TMP("DDSDFRM",$JOB,"BLK"))
+3 KILL @DDSBLK
+4 QUIT
+5 ;
QUIT ;Cleanup
+1 KILL @DDSBLK
+2 KILL DDSBLK,DDSDEL,DDSFILE,DDSFORM,DDSQUIT
+3 KILL DDH,DIRUT,DIROUT,DTOUT,DUOUT
+4 QUIT
+5 ;
FORM() ;Prompt for form
+1 ;Select file
+2 NEW D,DIC
+3 SET DDS1="DELETE FORM FROM"
DO W^DICRW
KILL DDS1
IF Y<0
GOTO FORMQ
+4 IF '$DATA(@(DIC_"0)"))
SET Y=-1
GOTO FORMQ
+5 SET DDSFILE=Y
+6 ;
+7 ;Select form
+8 WRITE !
KILL DIC
+9 SET DIC="^DIST(.403,"
SET DIC(0)="QEAM"
+10 SET DIC(0)="QEA"
SET D="F"_+DDSFILE
+11 SET DIC("S")="I $P(^(0),U,8)=+DDSFILE"
+12 SET DIC("A")="Select FORM to delete: "
+13 SET DIC("W")=$PIECE($TEXT(DICW),";",3,999)
DICW ;;N %G,%Y S %Y=Y,%G=^(0) W:$X>35 ! W ?35,"#"_Y S Y=$P(%G,U,5) W:Y]"" ?43," "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y S Y=%Y
+1 DO IX^DIC
+2 ;
FORMQ QUIT Y
+1 ;
GETBLKS ;Get all blocks on form
+1 ; @DDSBLK@(bk#)=Block name^flag (1=used on other forms)
+2 ;
+3 NEW P,B
+4 SET P=0
FOR
SET P=$ORDER(^DIST(.403,+DDSFORM,40,P))
IF 'P
QUIT
Begin DoDot:1
+5 SET B=$PIECE(^DIST(.403,+DDSFORM,40,P,0),U,2)
+6 IF B]""
IF '$DATA(@DDSBLK@(B))
Begin DoDot:2
+7 SET @DDSBLK@(B)=$PIECE($GET(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
End DoDot:2
+8 SET B=0
+9 FOR
SET B=$ORDER(^DIST(.403,+DDSFORM,40,P,40,B))
IF 'B
QUIT
IF '$DATA(@DDSBLK@(B))
Begin DoDot:2
+10 SET @DDSBLK@(B)=$PIECE($GET(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
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 IF $PIECE(@DDSBLK@(DDSB),U,2)
QUIT
+10 SET DIR("A")=$PIECE(@DDSBLK@(DDSB),U)_$JUSTIFY("",30-$LENGTH($PIECE(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? "
+11 DO ^DIR
IF $DATA(DIRUT)
SET DDSQUIT=1
IF 'Y
QUIT
+12 SET DA=DDSB
DO ^DIK
End DoDot:1
+13 KILL DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT
+14 QUIT
+15 ;
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 IF $PIECE(@DDSBLK@(DDSB),U,2)
QUIT
+7 WRITE !,"Deleting block "_$PIECE(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..."
+8 SET DA=DDSB
DO ^DIK
End DoDot:1
+9 KILL DIK,DA
+10 QUIT
+11 ;
ASKDEL ;Ask if user wants to delete all the blocks on this form
+1 KILL DIR
WRITE !
SET DIR(0)="YA"
SET DIR("B")="YES"
+2 SET DIR("A",1)=""
+3 SET DIR("A",2)="Delete all deletable blocks used on form "_$PIECE(DDSFORM,U,2)
+4 SET DIR("A")="from the BLOCK file (Y/N)? "
+5 SET DIR("?",1)=" Enter 'Y' to delete blocks used on form"
+6 SET DIR("?",2)=" "_$PIECE(DDSFORM,U,2)_" from the BLOCK file."
+7 SET DIR("?",3)=" (Only blocks not used on other forms can be deleted.)"
+8 SET DIR("?",4)=""
+9 SET DIR("?")=" Enter 'N' to delete the form but not the blocks."
+10 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET DDSQUIT=1
QUIT
+11 SET DDSDEL=Y
IF 'DDSDEL
QUIT
+12 ;
+13 ;Ask if user wants to delete without prompting
+14 WRITE !
SET DIR(0)="YA"
SET DIR("B")="NO"
+15 SET DIR("A",1)=""
+16 SET DIR("A")="Delete blocks without prompting (Y/N)? "
+17 SET DIR("?",1)=" Enter 'Y' to delete blocks from the BLOCK file"
+18 SET DIR("?",2)=" without confirmation."
+19 SET DIR("?",3)=""
+20 SET DIR("?")=" Enter 'N' to confirm each delete."
+21 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET DDSQUIT=1
QUIT
+22 SET DDSDEL(1)=Y
+23 QUIT
+24 ;
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 !!!
IF '$DATA(@DDSBLK)
WRITE "There are no blocks on this form."
QUIT
+3 WRITE " BLOCKS USED ON FORM """_$PIECE(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
+4 WRITE !!," Internal",?50,"Used on"
+5 WRITE !," Entry Number Block Name",?50,"Other Forms? Deletable?"
+6 WRITE !," ------------ ----------",?50,"------------ ----------"
+7 ;
+8 SET B=""
FOR
SET B=$ORDER(@DDSBLK@(B))
IF B=""
QUIT
Begin DoDot:1
+9 WRITE !," "_B,?17,$PIECE(@DDSBLK@(B),U),?54
+10 WRITE $SELECT($PIECE(@DDSBLK@(B),U,2):"YES",1:"NO")
+11 WRITE ?68,$SELECT($PIECE(@DDSBLK@(B),U,2):"NO",1:"YES")
End DoDot:1
+12 QUIT
+13 ;
COMMON(B,F) ;Is block B found on forms other than F
+1 NEW C,F1
+2 SET C=0
SET F1=""
+3 FOR
SET F1=$ORDER(^DIST(.403,"AB",B,F1))
IF F1=""
QUIT
IF F1'=F
SET C=1
QUIT
+4 IF 'C
SET F1=""
FOR
SET F1=$ORDER(^DIST(.403,"AC",B,F1))
IF F1=""
QUIT
IF F1'=F
SET C=1
QUIT
+5 QUIT C
