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

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1DIB ;SFISC/GFT,XAK-CREATE A NEW FILE ;8:53 AM 27 Mar 2002
2 ;;22.0;VA FileMan;**107**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 W !! K DLAYGO,DTOUT D W^DICRW G Q:$D(DTOUT) K DICS,DIA Q:Y<0
51 Q:'$D(@(DIC_"0)")) I $P($G(^DD(+$P(@(DIC_"0)"),U,2),0,"DI")),U,2)["Y" W !!,$C(7),"RESTRICTED"_$S($P(^("DI"),U)["Y":" (ARCHIVE)",1:"")_" FILE - NO EDITING ALLOWED!" Q
6 S:$D(@(DIC_"0)")) DIA=DIC,X=^(0),(DI,J(0),DIA("P"))=+$P(X,U,2)
7 D QQ S DR="",(L,DRS,DIAP,DB,DSC)=0,F=-1,I(0)=DIA,DXS=1
8 D EN^DIA:$O(^DD(DI,.01))>0 I $D(DR) G ^DIA2
9Q K DI,DLAYGO,DIA,I,J
10QQ K ^UTILITY($J),DIAT,DIAB,DIZ,DIAO,DIAP,DIAA,IOP,DSC,DHIT,DRS,DIE,DR,DA,DG,DIC,F,DP,DQ,DV,DB,DW,D,X,Y,L,DIZZ Q
11 ;
12DIE ;
13 S F=+Y,(DG,X)="^DIZ("_F_","
14 I DUZ(0)="@" W !!,"INTERNAL GLOBAL REFERENCE: "_DG R "// ",X:DTIME S:'$T X="^" S:X="" X=DG I X?."?" W !,"TYPE A GLOBAL NAME, LIKE '^GLOBAL(' OR '^GLOBAL(4,'",!,"OR JUST HIT 'RETURN' TO STORE DATA IN '"_DG_"'" G DIE
15 ;
16 I X?1"^".E S X=$P(X,U,2,9) I X?.P G ABORT
17 I X?1.AN W $C(7)_" ??" G DIE
18 ;
19 S DG=X
20 D VALROOT(.X,.%)
21 I %'=1 G DIE:DUZ(0)="@"&(DG'=X),ABORT
22 ;
23 W !
24 W:DG'=X !?2,"Global reference selected: ^"_X,!
25 S DG=U_X
26 ;
27SET D WAIT^DICD S $P(^DIC(F,0),U,2)=F,^("%A")=DUZ_U_DT,X=$P(^(0),U,1),^(0,"GL")=DG
28 I DUZ(0)]"" F %="DD","DEL","RD","WR","LAYGO","AUDIT" S ^DIC(F,0,%)=DUZ(0)
29 I DUZ(0)'="@",$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) D SET1
30 S %="" I @("$D("_DG_"0))") S %=^(0)
31 S @(DG_"0)=X_U_F_U_$P(%,U,3,9)")
32 K ^DD(F) S ^(F,0)="FIELD^^.01^1",^DD(F,.01,0)="NAME^RF^^0;1^K:$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E) X"
33 S ^(3)="NAME MUST BE 3-30 CHARACTERS, NOT NUMERIC OR STARTING WITH PUNCTUATION" W !?5,"A FreeText NAME Field (#.01) has been created."
34 S DA="B",^DD(F,.01,1,0)="^.1",^(1,0)=F_U_DA,X=DG_""""_DA_""",$E(X,1,30),DA)",^(1)="S "_X_"=""""",^(2)="K "_X
35 S DIK="^DIC(",DA=F D IX1^DIK
36 S DLAYGO=F,DIK="^DD(DLAYGO,",DA=.01,DA(1)=DLAYGO G IX1^DIK
37 ;
38ABORT ;Delete file and abort
39 W !!?9,$C(7)_"No new file created!"
40 S DIK="^DIC(",DA=F
41 K DG
42 G ^DIK
43 ;
44VALROOT(X,%) ;Validate the root in X
45 ;Returns:
46 ; X = open root
47 ; % = 0 : invalid root
48 ; 1 : valid root
49 ;
50 N CREF,FNUM,N,OREF,PROMPT,QLEN,ROOT
51 ;
52 S (OREF,X)=$$OREF^DILF(X)
53 S:$E(OREF)=U OREF=$E(OREF,2,999)
54 ;
55 ;Check syntax
56 I OREF?1(1A,1"%").AN1"("
57 E I OREF?1(1A,1"%").AN1"("1.E1","
58 E I OREF?1"["1.E1"]"1(1A,1"%").AN1"("
59 E I OREF?1"["1.E1"]"1(1A,1"%").AN1"("1.E1","
60 E I OREF?1"|"1.E1"|"1(1A,1"%").AN1"("
61 E I OREF?1"|"1.E1"|"1(1A,1"%").AN1"("1.E1","
62 E W $C(7)_" ?? Bad syntax" S %=0 Q
63 ;
64 S CREF=U_$$CREF^DILF(OREF)
65 ;
66 ;Check whether files stored in ancestors
67 S %=1
68 S QLEN=$QL($NA(@CREF))
69 F N=QLEN:-1:0 D Q:'%
70 . S ROOT=$NA(@CREF,N)
71 . Q:ROOT="^DIC"&(N'=QLEN)
72 . S FNUM=+$P($P($G(@ROOT@(0)),U,2),"E")
73 . I FNUM D Q:'%
74 .. S OROOT=$$OREF^DILF(ROOT)
75 .. I $G(^DIC(FNUM,0,"GL"))=OROOT D
76 ... W !!,$C(7)_" ERROR -- "_OROOT_" already used by File #"_FNUM_"!"
77 ... S %=0
78 . I N=QLEN,$O(@CREF@(0))]"" D
79 .. W !,$C(7)
80 .. S PROMPT=" -- ^"_OREF_" already exists!"
81 .. I DUZ(0)'="@" S %=0 W !," ERROR"_PROMPT
82 .. E D YN(" WARNING"_PROMPT_" --OK",.%)
83 Q
84 ;
85YN(PROMPT,%) ;Prompt yes/no
86 N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
87 S DIR(0)="Y"
88 S:$G(PROMPT)]"" DIR("A")=PROMPT
89 S DIR("B")="No"
90 D ^DIR
91 S %=Y=1
92 Q
93 ;
94EN ; Enter here when the user is allowed to select his fields
95 S DIC=DIE S:DIC DIC=$S($D(^DIC(DIC,0,"GL")):^("GL"),1:"")
96 D 1:DIC]"" K DIC Q
97 ;
98SET1 ;
99 I $D(^VA(200,"AFOF")) S:'$D(^VA(200,DUZ,"FOF",0)) ^(0)="^200.032PA^"_+F_"^1" S ^(+F,0)=F_"^1^1^1^1^1^1"
100 I $D(^DIC(3,"AFOF")) S:'$D(^DIC(3,DUZ,"FOF",0)) ^(0)="^3.032PA^"_+F_"^1" S ^(+F,0)=F_"^1^1^1^1^1^1"
101 S DIK=$S($D(^VA(200)):"^VA(200,DUZ,""FOF"",",1:"^DIC(3,DUZ,""FOF"","),DA=F,DA(1)=DUZ D IX1^DIK
102 Q
Note: See TracBrowser for help on using the repository browser.