Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DDSDFRM

DDSDFRM.m

Go to the documentation of this file. 
  1. DDSDFRM ;SFISC/MKO-DELETE A FORM ;09:12 AM  18 Aug 1994
  1.  ;;22.0;VA FileMan;;Mar 30, 1999
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  N %,DIC,DIOVRD,X,Y
  1.  D INIT
  1.  S (DDSDEL,DDSQUIT)=0
  1.  ;
  1.  S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
  1.  ;
  1.  D GETBLKS
  1.  D REPORT
  1.  I $D(@DDSBLK) D ASKDEL G:DDSQUIT QUIT
  1.  D ASKCONT G:DDSQUIT QUIT
  1.  ;
  1.  ;Delete form
  1.  W !!,"Deleting form "_$P(DDSFORM,U,2)_" (IEN #"_+DDSFORM_") ..."
  1.  S DIK="^DIST(.403,",DA=+DDSFORM
  1.  D ^DIK K DIK,DA
  1.  ;
  1.  ;Delete blocks
  1.  I DDSDEL D:'$G(DDSDEL(1)) DELPR D:$G(DDSDEL(1)) DELNPR
  1.  W !!,"DONE!"
  1.  D QUIT
  1.  Q
  1.  ;
  1. EN(DDSFORM) ;Delete form number DDSFORM
  1.  N %,DA,DDSB,DDSBLK,DIC,DIK,DIOVRD,X,Y
  1.  I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
  1.  D INIT
  1.  D GETBLKS
  1.  ;
  1.  ;Delete form
  1.  S DIK="^DIST(.403,",DA=+DDSFORM
  1.  D ^DIK K DIK,DA
  1.  ;
  1.  ;Delete blocks
  1.  S DIK="^DIST(.404,"
  1.  S DDSB="" F  S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""  D
  1.  . Q:$P(@DDSBLK@(DDSB),U,2)
  1.  . S DA=DDSB D ^DIK
  1.  ;
  1.  K @DDSBLK
  1.  Q
  1.  ;
  1. INIT ;Setup
  1.  S DIOVRD=1
  1.  S DDSBLK=$NA(^TMP("DDSDFRM",$J,"BLK"))
  1.  K @DDSBLK
  1.  Q
  1.  ;
  1. QUIT ;Cleanup
  1.  K @DDSBLK
  1.  K DDSBLK,DDSDEL,DDSFILE,DDSFORM,DDSQUIT
  1.  K DDH,DIRUT,DIROUT,DTOUT,DUOUT
  1.  Q
  1.  ;
  1. FORM() ;Prompt for form
  1.  ;Select file
  1.  N D,DIC
  1.  S DDS1="DELETE FORM FROM" D W^DICRW K DDS1 G:Y<0 FORMQ
  1.  I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
  1.  S DDSFILE=Y
  1.  ;
  1.  ;Select form
  1.  W ! K DIC
  1.  S DIC="^DIST(.403,",DIC(0)="QEAM"
  1.  S DIC(0)="QEA",D="F"_+DDSFILE
  1.  S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
  1.  S DIC("A")="Select FORM to delete: "
  1.  S DIC("W")=$P($T(DICW),";",3,999)
  1. 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.  D IX^DIC
  1.  ;
  1. FORMQ Q Y
  1.  ;
  1. GETBLKS ;Get all blocks on form
  1.  ; @DDSBLK@(bk#)=Block name^flag (1=used on other forms)
  1.  ;
  1.  N P,B
  1.  S P=0 F  S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P  D
  1.  . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
  1.  . I B]"",'$D(@DDSBLK@(B)) D
  1.  .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
  1.  . S B=0
  1.  . F  S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B  D:'$D(@DDSBLK@(B))
  1.  .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
  1.  Q
  1.  ;
  1. DELPR ;Delete blocks with prompting
  1.  N DDSB
  1.  W ! K DIK,DIR,DIRUT
  1.  S DIR(0)="YA",DIR("B")="NO"
  1.  S DIR("?")="  Enter 'Y' to delete, 'N' to keep."
  1.  S DIK="^DIST(.404,"
  1.  ;
  1.  S DDSB=""
  1.  F  S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT  D
  1.  . Q:$P(@DDSBLK@(DDSB),U,2)
  1.  . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? "
  1.  . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y
  1.  . S DA=DDSB D ^DIK
  1.  K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT
  1.  Q
  1.  ;
  1. DELNPR ;Delete blocks without prompting
  1.  N DDSB
  1.  W ! K DIK
  1.  S DIK="^DIST(.404,"
  1.  S DDSB=""
  1.  F  S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""  D
  1.  . Q:$P(@DDSBLK@(DDSB),U,2)
  1.  . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..."
  1.  . S DA=DDSB D ^DIK
  1.  K DIK,DA
  1.  Q
  1.  ;
  1. ASKDEL ;Ask if user wants to delete all the blocks on this form
  1.  K DIR W ! S DIR(0)="YA",DIR("B")="YES"
  1.  S DIR("A",1)=""
  1.  S DIR("A",2)="Delete all deletable blocks used on form "_$P(DDSFORM,U,2)
  1.  S DIR("A")="from the BLOCK file (Y/N)? "
  1.  S DIR("?",1)="  Enter 'Y' to delete blocks used on form"
  1.  S DIR("?",2)="    "_$P(DDSFORM,U,2)_" from the BLOCK file."
  1.  S DIR("?",3)="    (Only blocks not used on other forms can be deleted.)"
  1.  S DIR("?",4)=""
  1.  S DIR("?")="  Enter 'N' to delete the form but not the blocks."
  1.  D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
  1.  S DDSDEL=Y Q:'DDSDEL
  1.  ;
  1.  ;Ask if user wants to delete without prompting
  1.  W ! S DIR(0)="YA",DIR("B")="NO"
  1.  S DIR("A",1)=""
  1.  S DIR("A")="Delete blocks without prompting (Y/N)? "
  1.  S DIR("?",1)="  Enter 'Y' to delete blocks from the BLOCK file"
  1.  S DIR("?",2)="    without confirmation."
  1.  S DIR("?",3)=""
  1.  S DIR("?")="  Enter 'N' to confirm each delete."
  1.  D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
  1.  S DDSDEL(1)=Y
  1.  Q
  1.  ;
  1. ASKCONT ;Final chance to abort
  1.  K DIR S DIR(0)="YA",DIR("B")="NO"
  1.  S DIR("A",1)=""
  1.  S DIR("A")="Continue (Y/N)? "
  1.  S DIR("?")="  Enter 'Y' to delete form.  Enter 'N' to exit."
  1.  D ^DIR K DIR
  1.  S:$D(DIRUT)!'Y DDSQUIT=1
  1.  Q
  1.  ;
  1. REPORT ;Print report
  1.  N B
  1.  W !!! I '$D(@DDSBLK) W "There are no blocks on this form." Q
  1.  W "  BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
  1.  W !!,"  Internal",?50,"Used on"
  1.  W !,"  Entry Number   Block Name",?50,"Other Forms?   Deletable?"
  1.  W !,"  ------------   ----------",?50,"------------   ----------"
  1.  ;
  1.  S B="" F  S B=$O(@DDSBLK@(B)) Q:B=""  D
  1.  . W !,"  "_B,?17,$P(@DDSBLK@(B),U),?54
  1.  . W $S($P(@DDSBLK@(B),U,2):"YES",1:"NO")
  1.  . W ?68,$S($P(@DDSBLK@(B),U,2):"NO",1:"YES")
  1.  Q
  1.  ;
  1. COMMON(B,F) ;Is block B found on forms other than F
  1.  N C,F1
  1.  S C=0,F1=""
  1.  F  S F1=$O(^DIST(.403,"AB",B,F1)) Q:F1=""  I F1'=F S C=1 Q
  1.  I 'C S F1="" F  S F1=$O(^DIST(.403,"AC",B,F1)) Q:F1=""  I F1'=F S C=1 Q
  1.  Q C