Annotation of freem_fileman/DDSDFRM.m, revision 1.1
1.1 ! snw 1: DDSDFRM ;SFISC/MKO-DELETE A FORM ;09:12 AM 18 Aug 1994
! 2: ;;21.0;VA FileMan;;Dec 28, 1994
! 3: ;Per VHA Directive 10-93-142, this routine should not be modified.
! 4: ;
! 5: N %,DIC,DIOVRD,X,Y
! 6: D INIT
! 7: S (DDSDEL,DDSQUIT)=0
! 8: ;
! 9: S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
! 10: ;
! 11: D GETBLKS
! 12: D REPORT
! 13: I $D(@DDSBLK) D ASKDEL G:DDSQUIT QUIT
! 14: D ASKCONT G:DDSQUIT QUIT
! 15: ;
! 16: ;Delete form
! 17: W !!,"Deleting form "_$P(DDSFORM,U,2)_" (IEN #"_+DDSFORM_") ..."
! 18: S DIK="^DIST(.403,",DA=+DDSFORM
! 19: D ^DIK K DIK,DA
! 20: ;
! 21: ;Delete blocks
! 22: I DDSDEL D:'$G(DDSDEL(1)) DELPR D:$G(DDSDEL(1)) DELNPR
! 23: W !!,"DONE!"
! 24: D QUIT
! 25: Q
! 26: ;
! 27: EN(DDSFORM) ;Delete form number DDSFORM
! 28: N %,DA,DDSB,DDSBLK,DIC,DIK,DIOVRD,X,Y
! 29: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
! 30: D INIT
! 31: D GETBLKS
! 32: ;
! 33: ;Delete form
! 34: S DIK="^DIST(.403,",DA=+DDSFORM
! 35: D ^DIK K DIK,DA
! 36: ;
! 37: ;Delete blocks
! 38: S DIK="^DIST(.404,"
! 39: S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D
! 40: . Q:$P(@DDSBLK@(DDSB),U,2)
! 41: . S DA=DDSB D ^DIK
! 42: ;
! 43: K @DDSBLK
! 44: Q
! 45: ;
! 46: INIT ;Setup
! 47: S DIOVRD=1
! 48: S DDSBLK=$NA(^TMP("DDSDFRM",$J,"BLK"))
! 49: K @DDSBLK
! 50: Q
! 51: ;
! 52: QUIT ;Cleanup
! 53: K @DDSBLK
! 54: K DDSBLK,DDSDEL,DDSFILE,DDSFORM,DDSQUIT
! 55: K DDH,DIRUT,DIROUT,DTOUT,DUOUT
! 56: Q
! 57: ;
! 58: FORM() ;Prompt for form
! 59: ;Select file
! 60: N D,DIC
! 61: S DDS1="DELETE FORM FROM" D W^DICRW K DDS1 G:Y<0 FORMQ
! 62: I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
! 63: S DDSFILE=Y
! 64: ;
! 65: ;Select form
! 66: W ! K DIC
! 67: S DIC="^DIST(.403,",DIC(0)="QEAM"
! 68: S DIC(0)="QEA",D="F"_+DDSFILE
! 69: S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
! 70: S DIC("A")="Select FORM to delete: "
! 71: S DIC("W")=$P($T(DICW),";",3,999)
! 72: 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
! 73: D IX^DIC
! 74: ;
! 75: FORMQ Q Y
! 76: ;
! 77: GETBLKS ;Get all blocks on form
! 78: ; @DDSBLK@(bk#)=Block name^flag (1=used on other forms)
! 79: ;
! 80: N P,B
! 81: S P=0 F S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P D
! 82: . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
! 83: . I B]"",'$D(@DDSBLK@(B)) D
! 84: .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
! 85: . S B=0
! 86: . F S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B D:'$D(@DDSBLK@(B))
! 87: .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
! 88: Q
! 89: ;
! 90: DELPR ;Delete blocks with prompting
! 91: N DDSB
! 92: W ! K DIK,DIR,DIRUT
! 93: S DIR(0)="YA",DIR("B")="NO"
! 94: S DIR("?")=" Enter 'Y' to delete, 'N' to keep."
! 95: S DIK="^DIST(.404,"
! 96: ;
! 97: S DDSB=""
! 98: F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT D
! 99: . Q:$P(@DDSBLK@(DDSB),U,2)
! 100: . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? "
! 101: . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y
! 102: . S DA=DDSB D ^DIK
! 103: K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT
! 104: Q
! 105: ;
! 106: DELNPR ;Delete blocks without prompting
! 107: N DDSB
! 108: W ! K DIK
! 109: S DIK="^DIST(.404,"
! 110: S DDSB=""
! 111: F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D
! 112: . Q:$P(@DDSBLK@(DDSB),U,2)
! 113: . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..."
! 114: . S DA=DDSB D ^DIK
! 115: K DIK,DA
! 116: Q
! 117: ;
! 118: ASKDEL ;Ask if user wants to delete all the blocks on this form
! 119: K DIR W ! S DIR(0)="YA",DIR("B")="YES"
! 120: S DIR("A",1)=""
! 121: S DIR("A",2)="Delete all deletable blocks used on form "_$P(DDSFORM,U,2)
! 122: S DIR("A")="from the BLOCK file (Y/N)? "
! 123: S DIR("?",1)=" Enter 'Y' to delete blocks used on form"
! 124: S DIR("?",2)=" "_$P(DDSFORM,U,2)_" from the BLOCK file."
! 125: S DIR("?",3)=" (Only blocks not used on other forms can be deleted.)"
! 126: S DIR("?",4)=""
! 127: S DIR("?")=" Enter 'N' to delete the form but not the blocks."
! 128: D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
! 129: S DDSDEL=Y Q:'DDSDEL
! 130: ;
! 131: ;Ask if user wants to delete without prompting
! 132: W ! S DIR(0)="YA",DIR("B")="NO"
! 133: S DIR("A",1)=""
! 134: S DIR("A")="Delete blocks without prompting (Y/N)? "
! 135: S DIR("?",1)=" Enter 'Y' to delete blocks from the BLOCK file"
! 136: S DIR("?",2)=" without confirmation."
! 137: S DIR("?",3)=""
! 138: S DIR("?")=" Enter 'N' to confirm each delete."
! 139: D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
! 140: S DDSDEL(1)=Y
! 141: Q
! 142: ;
! 143: ASKCONT ;Final chance to abort
! 144: K DIR S DIR(0)="YA",DIR("B")="NO"
! 145: S DIR("A",1)=""
! 146: S DIR("A")="Continue (Y/N)? "
! 147: S DIR("?")=" Enter 'Y' to delete form. Enter 'N' to exit."
! 148: D ^DIR K DIR
! 149: S:$D(DIRUT)!'Y DDSQUIT=1
! 150: Q
! 151: ;
! 152: REPORT ;Print report
! 153: N B
! 154: W !!! I '$D(@DDSBLK) W "There are no blocks on this form." Q
! 155: W " BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
! 156: W !!," Internal",?50,"Used on"
! 157: W !," Entry Number Block Name",?50,"Other Forms? Deletable?"
! 158: W !," ------------ ----------",?50,"------------ ----------"
! 159: ;
! 160: S B="" F S B=$O(@DDSBLK@(B)) Q:B="" D
! 161: . W !," "_B,?17,$P(@DDSBLK@(B),U),?54
! 162: . W $S($P(@DDSBLK@(B),U,2):"YES",1:"NO")
! 163: . W ?68,$S($P(@DDSBLK@(B),U,2):"NO",1:"YES")
! 164: Q
! 165: ;
! 166: COMMON(B,F) ;Is block B found on forms other than F
! 167: N C,F1
! 168: S C=0,F1=""
! 169: F S F1=$O(^DIST(.403,"AB",B,F1)) Q:F1="" I F1'=F S C=1 Q
! 170: I 'C S F1="" F S F1=$O(^DIST(.403,"AC",B,F1)) Q:F1="" I F1'=F S C=1 Q
! 171: Q C
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DDSDFRM.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman