source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIU21.m@ 1801

Last change on this file since 1801 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1DIU21 ;SFISC/XAK-EDIT FILE (PGMR PART) ;06:21 PM 2 Apr 2001
2 ;;22.0;VA FileMan;**82**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D:'$D(DISYS) OS^DII Q:$G(^DD("OS",DISYS,18))=""
5SCR K DIR S DIR(0)="FOU^3:250",DIR("A")="FILE SCREEN" S:$D(^DD(DA,0,"SCR")) DIR("B")=^("SCR")
6 S DIR("?")="IF MUMPS CODE IS ENTERED HERE, IT IS A PERMANENT 'DIC(""S"")' FOR FILE"
7 D ^DIR G:$D(DTOUT)!($D(DUOUT)) Q K DIRUT,DIROUT G:X="" ACT
8 I "@"'[X D ^DIM I $D(X) S ^DD(DA,0,"SCR")=X S:DIU(0)'["s" $P(@(DIU_"0)"),U,2)=DIU(0)_"s" G ACT
9 I $G(X)="@" K ^DD(DA,0,"SCR") S $P(@(DIU_"0)"),U,2)=$TR(DIU(0),"s") W " "_$$EZBLD^DIALOG(8015) G ACT
10 W $C(7)," ",$$EZBLD^DIALOG(9025) G SCR
11ACT K DIR S DIR(0)="FOU^3:250",DIR("A")=$$EZBLD^DIALOG(8013) S:$D(^DD(DA,0,"ACT")) DIR("B")=^("ACT")
12 S DIR("?",1)=$$EZBLD^DIALOG(9025),DIR("?")=$$EZBLD^DIALOG(9024)
13 D ^DIR G:$D(DTOUT)!($D(DUOUT)) Q K DIRUT,DIROUT G:X="" DIC
14 I "@"'[X D ^DIM I $D(X) S ^DD(DA,0,"ACT")=X G DIC
15 I $G(X)="@" K ^DD(DA,0,"ACT") W " "_$$EZBLD^DIALOG(8015) G DIC
16 W $C(7)," ",$$EZBLD^DIALOG(9025) G ACT
17DIC K DIR N Y,DIPARAM S DIR(0)="FO^3:8^K:X?1""DI"".E X",DIR("A")=$$EZBLD^DIALOG(8014) S:$G(^DD(DA,0,"DIC"))]"" DIR("B")=^("DIC")
18 S DIPARAM=9026,DIPARAM(1)=8 D H,H1
19 D ^DIR K DIRUT,DIROUT
20 G:$D(DTOUT)!($D(DUOUT)) Q G:X="" DIK
21 I X="@" K ^DD(DA,0,"DIC") W " "_$$EZBLD^DIALOG(8015) G DIK
22 I '$$ROUEXIST^DILIBF(X) W $C(7)," ",$$EZBLD^DIALOG(8017) G DIC
23 S ^DD(DA,0,"DIC")=X
24DIK S X=$G(^DD(DA,0,"DIKOLD")),Y=$G(^("DIK")) I X]"",X'=Y W !," " D BLD^DIALOG(8018,X,"","DIR") W DIR
25 K DIR S DIR(0)="FO^3:6^K:X?1""DI"".E X",DIR("A")=$$EZBLD^DIALOG(8019) S:Y]"" DIR("B")=Y
26 S DIPARAM=9027,DIPARAM(1)=6 D H,H1
27 D ^DIR I X="@" G QA
28 G:$D(DIRUT)!(X="") Q
29 I $$ROUEXIST^DILIBF(X) W $C(7),! S DIPARAM(1)=X D BLD^DIALOG(8016,.DIPARAM,"","DIR") W DIR
30 K DIR N DICMP S DICMP=0 I $G(^DD(DA,0,"DIK"))=""!($G(^("DIK"))'=X) S DICMP=1
31 N DIKPGM S DIKPGM=X
32 S DIR(0)="YO",DIR("A")=$$EZBLD^DIALOG(8020)
33 I 'DICMP S DIR("B")="NO" D BLD^DIALOG(9028,"","","DIR(""?"")")
34 I DICMP S DIR("B")="YES" D BLD^DIALOG(9029,"","","DIR(""?"")")
35 D ^DIR G Q:$D(DIRUT)
36 I 'Y G:'DICMP Q W $C(7) G QA
37 S X=DIKPGM,Y=DA,DMAX=^DD("ROU") K DIR,DICMP,DIKPGM G EN^DIKZ
38 ;
39A N DA S DA=+X N X K ^DD(DA,0,"DIK")
40 F X=0:0 S X=$O(^DD(DA,"SB",X)) Q:X'>0 D A
41 Q
42QA S X=DA D A W " "_$$EZBLD^DIALOG(8015),!," ",$$EZBLD^DIALOG(8021)
43Q Q
44H ; Build help for entering routine name.
45 D BLD^DIALOG(9006,.DIPARAM,"","DIR(""?"")") Q
46H1 N I S I=$O(DIR("?",":"),-1) I I S DIR("?",I+1)=DIR("?")
47 I DIPARAM=9027 S DIR("?",I+2)=$$EZBLD^DIALOG(9030)
48 D BLD^DIALOG(DIPARAM,"","","DIR(""?"")") Q
49 ;
50DIE ;not in 20
51 I $P($G(^DD(DA,0,"DI")),U)["Y" W !,$C(7),"RESTRICT EDITING OF FILE? YES// (UNEDITABLE) THIS IS AN ARCHIVE FILE." Q
52 N DIR,DIEYN S DIR(0)="YO",DIR("A")="RESTRICT EDITING OF FILE",DIR("B")=$S($P($G(^DD(DA,0,"DI")),U,2)["Y":"YES",1:"NO")
53 S DIR("?",1)="YES will not allow editing or deleting existing file entries or adding new file entries",DIR("?")="NO will place no restrictions on the file"
54 D ^DIR Q:$D(DTOUT)!$D(DUOUT)
55 S DIEYN=$S(Y:"Y",1:"N")
56 D DIE1 Q:$D(DTOUT)!($D(DUOUT)) G:'$D(DIEYN) DIE
57 S $P(^DD(DA,0,"DI"),U,2)=DIEYN
58 Q
59DIE1 Q:Y&($E(DIR("B"))="Y") Q:'Y&($E(DIR("B"))="N")
60 I Y W !,$C(7),"WARNING- DATA IN THIS FILE IS NOW UNEDITABLE"
61 I 'Y W !,$C(7),"WARNING- DATA IN THIS FILE IS NOW EDITABLE"
62 K DIR S DIR(0)="Y",DIR("A")="ARE YOU SURE"
63 D ^DIR Q:$D(DTOUT)!$D(DUOUT) K:'Y DIEYN
64 Q
65 ;
66 ;DIALOG #8013 'POST-SELECTION ACTION'
67 ; #8014 'LOOK-UP PROGRAM'
68 ; #8015 'Deleted.'
69 ; #8016 'Note that...is already in the routine directory.'
70 ; #8017 'This routine does not exist in the routine directory.'
71 ; #8018 'Previously compiled under routine name...'
72 ; #8019 'CROSS-REFERENCE ROUTINE'
73 ; #8020 'Should the compilation run now'
74 ; #8021 'The compiled routines will no longer be used...'
75 ; #9006 'Enter a valid MUMPS routine name of from 3 to...'
76 ; #9024 'This code will be executed whenever an entry is...'
77 ; #9025 'Enter a line of standard MUMPS code'
78 ; #9026 'This special lookup routine will be executed...'
79 ; #9027 'if a NEW routine name is entered, but the cross-ref...'
80 ; #9028 'It is not necessary to recompile the cross-ref...'
81 ; #9029 'If the cross-references are not recompiled...'
82 ; #9030 'This will become the namespace of the compiled routine'
Note: See TracBrowser for help on using the repository browser.