Return to DDSDFRM.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

DDSDFRM	;SFISC/MKO-DELETE A FORM ;09:12 AM  18 Aug 1994
	;;21.0;VA FileMan;;Dec 28, 1994
	;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