DDSDFRM ;SFISC/MKO-DELETE A FORM ;11:22 AM 4 Dec 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 %,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
EGP S DDS1=8108.2 D W^DICRW K DDS1 G:Y<0 FORMQ ;**CCO/NI 'DELETE FORM'
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 S %G=^(0) W:$X>35 ! W ?35,"#"_Y N Y S Y=$P(%G,U,5) W:Y]"" ?43,$$OUT^DIALOGU(Y,"FMTE","2D") S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y ;**CCO/NI NICE DATE FORMAT
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSDFRM 5164 printed Oct 16, 2024@18:43:52 Page 2
DDSDFRM ;SFISC/MKO-DELETE A FORM ;11:22 AM 4 Dec 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 %,DIC,DIOVRD,X,Y
+8 DO INIT
+9 SET (DDSDEL,DDSQUIT)=0
+10 ;
+11 SET DDSFORM=$$FORM
if DDSFORM=-1
GOTO QUIT
+12 ;
+13 DO GETBLKS
+14 DO REPORT
+15 IF $DATA(@DDSBLK)
DO ASKDEL
if DDSQUIT
GOTO QUIT
+16 DO ASKCONT
if DDSQUIT
GOTO QUIT
+17 ;
+18 ;Delete form
+19 WRITE !!,"Deleting form "_$PIECE(DDSFORM,U,2)_" (IEN #"_+DDSFORM_") ..."
+20 SET DIK="^DIST(.403,"
SET DA=+DDSFORM
+21 DO ^DIK
KILL DIK,DA
+22 ;
+23 ;Delete blocks
+24 IF DDSDEL
if '$GET(DDSDEL(1))
DO DELPR
if $GET(DDSDEL(1))
DO DELNPR
+25 WRITE !!,"DONE!"
+26 DO QUIT
+27 QUIT
+28 ;
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
EGP ;**CCO/NI 'DELETE FORM'
SET DDS1=8108.2
DO W^DICRW
KILL DDS1
if Y<0
GOTO FORMQ
+1 IF '$DATA(@(DIC_"0)"))
SET Y=-1
GOTO FORMQ
+2 SET DDSFILE=Y
+3 ;
+4 ;Select form
+5 WRITE !
KILL DIC
+6 SET DIC="^DIST(.403,"
SET DIC(0)="QEAM"
+7 SET DIC(0)="QEA"
SET D="F"_+DDSFILE
+8 SET DIC("S")="I $P(^(0),U,8)=+DDSFILE"
+9 SET DIC("A")="Select FORM to delete: "
+10 SET DIC("W")=$PIECE($TEXT(DICW),";",3,999)
DICW ;;N %G S %G=^(0) W:$X>35 ! W ?35,"#"_Y N Y S Y=$P(%G,U,5) W:Y]"" ?43,$$OUT^DIALOGU(Y,"FMTE","2D") S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y ;**CCO/NI NICE DATE FORMAT
+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
