DIB ;SFISC/GFT,XAK-CREATE A NEW FILE ;9JUN2003
;;22.2;VA FileMan;**18**;Jan 05, 2016;Build 2
;;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.
;
W !! K DLAYGO,DTOUT D W^DICRW G Q:$D(DTOUT) K DICS,DIA Q:Y<0
1 I '$D(@(DIC_"0)")) W !!,$C(7),"DATA GLOBAL DOES NOT EXIST!" K DIC Q
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
S:$D(@(DIC_"0)")) DIA=DIC,X=^(0),(DI,J(0),DIA("P"))=+$P(X,U,2)
D QQ S DR="",(L,DRS,DIAP,DB,DSC)=0,F=-1,I(0)=DIA,DXS=1
D EN^DIA:$O(^DD(DI,.01))>0 I $D(DR) G ^DIA2
Q K DI,DLAYGO,DIA,I,J
QQ 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
;
DIE ;
S F=+Y,(DG,X)="^DIZ("_F_","
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
;
I X?1"^".E S X=$P(X,U,2,9) I X?.P G ABORT
I X?1.AN W $C(7)_" ??" G DIE
;
S DG=X
D VALROOT(.X,.%)
I %'=1 G DIE:DUZ(0)="@"&(DG'=X),ABORT
;
W !
W:DG'=X !?2,"Global reference selected: ^"_X,!
S DG=U_X
;
SET D WAIT^DICD S $P(^DIC(F,0),U,2)=F,^("%A")=DUZ_U_DT,X=$P(^(0),U,1),^(0,"GL")=DG
I DUZ(0)]"" F %="DD","DEL","RD","WR","LAYGO","AUDIT" S ^DIC(F,0,%)=DUZ(0)
I DUZ(0)'="@",$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) D SET1
S %="" I @("$D("_DG_"0))") S %=^(0)
S @(DG_"0)=X_U_F_U_$P(%,U,3,9)")
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"
S ^(3)="Name must be 3-30 characters, not numeric or starting with punctuation" W !?5,"A FreeText NAME Field (#.01) has been created." ;p18
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
S DIK="^DIC(",DA=F D IX1^DIK
S DLAYGO=F,DIK="^DD(DLAYGO,",DA=.01,DA(1)=DLAYGO G IX1^DIK
;
ABORT ;Delete file and abort
W !!?9,$C(7)_"No new file created!"
S DIK="^DIC(",DA=F
K DG
G ^DIK
;
VALROOT(X,%) ;Validate the root in X
;Returns:
; X = open root
; % = 0 : invalid root
; 1 : valid root
;
N CREF,FNUM,N,OREF,PROMPT,QLEN,ROOT
;
S (OREF,X)=$$OREF^DILF(X)
S:$E(OREF)=U OREF=$E(OREF,2,999)
;
;Check syntax
I OREF?1(1A,1"%").AN1"("
E I OREF?1(1A,1"%").AN1"("1.E1","
E I OREF?1"["1.E1"]"1(1A,1"%").AN1"("
E I OREF?1"["1.E1"]"1(1A,1"%").AN1"("1.E1","
E I OREF?1"|"1.E1"|"1(1A,1"%").AN1"("
E I OREF?1"|"1.E1"|"1(1A,1"%").AN1"("1.E1","
E W $C(7)_" ?? Bad syntax" S %=0 Q
;
S CREF=U_$$CREF^DILF(OREF)
;
;Check whether files stored in ancestors
S %=1
S QLEN=$QL($NA(@CREF))
F N=QLEN:-1:0 D Q:'%
. S ROOT=$NA(@CREF,N)
. Q:ROOT="^DIC"&(N'=QLEN)
. S FNUM=+$P($P($G(@ROOT@(0)),U,2),"E")
. I FNUM D Q:'%
.. S OROOT=$$OREF^DILF(ROOT)
.. I $G(^DIC(FNUM,0,"GL"))=OROOT D
... W !!,$C(7)_" ERROR -- "_OROOT_" already used by File #"_FNUM_"!"
... S %=0
. I N=QLEN,$O(@CREF@(0))]"" D
.. W !,$C(7)
.. S PROMPT=" -- ^"_OREF_" already exists!"
.. I DUZ(0)'="@" S %=0 W !," ERROR"_PROMPT
.. E D YN(" WARNING"_PROMPT_" --OK",.%)
Q
;
YN(PROMPT,%) ;Prompt yes/no
N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
S DIR(0)="Y"
S:$G(PROMPT)]"" DIR("A")=PROMPT
S DIR("B")="No"
D ^DIR
S %=Y=1
Q
;
EN ; Enter here when the user is allowed to select his fields
S DIC=DIE S:DIC DIC=$S($D(^DIC(DIC,0,"GL")):^("GL"),1:"")
D 1:DIC]"" K DIC Q
;
SET1 ;
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"
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"
S DIK=$S($D(^VA(200)):"^VA(200,DUZ,""FOF"",",1:"^DIC(3,DUZ,""FOF"","),DA=F,DA(1)=DUZ D IX1^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIB 4048 printed Sep 23, 2025@20:21:18 Page 2
DIB ;SFISC/GFT,XAK-CREATE A NEW FILE ;9JUN2003
+1 ;;22.2;VA FileMan;**18**;Jan 05, 2016;Build 2
+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 WRITE !!
KILL DLAYGO,DTOUT
DO W^DICRW
if $DATA(DTOUT)
GOTO Q
KILL DICS,DIA
if Y<0
QUIT
1 IF '$DATA(@(DIC_"0)"))
WRITE !!,$CHAR(7),"DATA GLOBAL DOES NOT EXIST!"
KILL DIC
QUIT
+1 IF $PIECE($GET(^DD(+$PIECE(@(DIC_"0)"),U,2),0,"DI")),U,2)["Y"
WRITE !!,$CHAR(7),"RESTRICTED"_$SELECT($PIECE(^("DI"),U)["Y":" (ARCHIVE)",1:"")_" FILE - NO EDITING ALLOWED!"
QUIT
+2 if $DATA(@(DIC_"0)"))
SET DIA=DIC
SET X=^(0)
SET (DI,J(0),DIA("P"))=+$PIECE(X,U,2)
+3 DO QQ
SET DR=""
SET (L,DRS,DIAP,DB,DSC)=0
SET F=-1
SET I(0)=DIA
SET DXS=1
+4 if $ORDER(^DD(DI,.01))>0
DO EN^DIA
IF $DATA(DR)
GOTO ^DIA2
Q KILL DI,DLAYGO,DIA,I,J
QQ KILL ^UTILITY($JOB),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
QUIT
+1 ;
DIE ;
+1 SET F=+Y
SET (DG,X)="^DIZ("_F_","
+2 IF DUZ(0)="@"
WRITE !!,"INTERNAL GLOBAL REFERENCE: "_DG
READ "// ",X:DTIME
if '$TEST
SET X="^"
if X=""
SET X=DG
IF X?."?"
WRITE !,"TYPE A GLOBAL NAME, LIKE '^GLOBAL(' OR '^GLOBAL(4,'",!,"OR JUST HIT 'RETURN' TO STORE DATA IN '"_DG_"'"
GOTO DIE
+3 ;
+4 IF X?1"^".E
SET X=$PIECE(X,U,2,9)
IF X?.P
GOTO ABORT
+5 IF X?1.AN
WRITE $CHAR(7)_" ??"
GOTO DIE
+6 ;
+7 SET DG=X
+8 DO VALROOT(.X,.%)
+9 IF %'=1
if DUZ(0)="@"&(DG'=X)
GOTO DIE
GOTO ABORT
+10 ;
+11 WRITE !
+12 if DG'=X
WRITE !?2,"Global reference selected: ^"_X,!
+13 SET DG=U_X
+14 ;
SET DO WAIT^DICD
SET $PIECE(^DIC(F,0),U,2)=F
SET ^("%A")=DUZ_U_DT
SET X=$PIECE(^(0),U,1)
SET ^(0,"GL")=DG
+1 IF DUZ(0)]""
FOR %="DD","DEL","RD","WR","LAYGO","AUDIT"
SET ^DIC(F,0,%)=DUZ(0)
+2 IF DUZ(0)'="@"
IF $SELECT($DATA(^VA(200,"AFOF")):1,1:$DATA(^DIC(3,"AFOF")))
DO SET1
+3 SET %=""
IF @("$D("_DG_"0))")
SET %=^(0)
+4 SET @(DG_"0)=X_U_F_U_$P(%,U,3,9)")
+5 KILL ^DD(F)
SET ^(F,0)="FIELD^^.01^1"
SET ^DD(F,.01,0)="NAME^RF^^0;1^K:$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E) X"
+6 ;p18
SET ^(3)="Name must be 3-30 characters, not numeric or starting with punctuation"
WRITE !?5,"A FreeText NAME Field (#.01) has been created."
+7 SET DA="B"
SET ^DD(F,.01,1,0)="^.1"
SET ^(1,0)=F_U_DA
SET X=DG_""""_DA_""",$E(X,1,30),DA)"
SET ^(1)="S "_X_"="""""
SET ^(2)="K "_X
+8 SET DIK="^DIC("
SET DA=F
DO IX1^DIK
+9 SET DLAYGO=F
SET DIK="^DD(DLAYGO,"
SET DA=.01
SET DA(1)=DLAYGO
GOTO IX1^DIK
+10 ;
ABORT ;Delete file and abort
+1 WRITE !!?9,$CHAR(7)_"No new file created!"
+2 SET DIK="^DIC("
SET DA=F
+3 KILL DG
+4 GOTO ^DIK
+5 ;
VALROOT(X,%) ;Validate the root in X
+1 ;Returns:
+2 ; X = open root
+3 ; % = 0 : invalid root
+4 ; 1 : valid root
+5 ;
+6 NEW CREF,FNUM,N,OREF,PROMPT,QLEN,ROOT
+7 ;
+8 SET (OREF,X)=$$OREF^DILF(X)
+9 if $EXTRACT(OREF)=U
SET OREF=$EXTRACT(OREF,2,999)
+10 ;
+11 ;Check syntax
+12 IF OREF?1(1A,1"%").AN1"("
+13 IF '$TEST
IF OREF?1(1A,1"%").AN1"("1.E1","
+14 IF '$TEST
IF OREF?1"["1.E1"]"1(1A,1"%").AN1"("
+15 IF '$TEST
IF OREF?1"["1.E1"]"1(1A,1"%").AN1"("1.E1","
+16 IF '$TEST
IF OREF?1"|"1.E1"|"1(1A,1"%").AN1"("
+17 IF '$TEST
IF OREF?1"|"1.E1"|"1(1A,1"%").AN1"("1.E1","
+18 IF '$TEST
WRITE $CHAR(7)_" ?? Bad syntax"
SET %=0
QUIT
+19 ;
+20 SET CREF=U_$$CREF^DILF(OREF)
+21 ;
+22 ;Check whether files stored in ancestors
+23 SET %=1
+24 SET QLEN=$QLENGTH($NAME(@CREF))
+25 FOR N=QLEN:-1:0
Begin DoDot:1
+26 SET ROOT=$NAME(@CREF,N)
+27 if ROOT="^DIC"&(N'=QLEN)
QUIT
+28 SET FNUM=+$PIECE($PIECE($GET(@ROOT@(0)),U,2),"E")
+29 IF FNUM
Begin DoDot:2
+30 SET OROOT=$$OREF^DILF(ROOT)
+31 IF $GET(^DIC(FNUM,0,"GL"))=OROOT
Begin DoDot:3
+32 WRITE !!,$CHAR(7)_" ERROR -- "_OROOT_" already used by File #"_FNUM_"!"
+33 SET %=0
End DoDot:3
End DoDot:2
if '%
QUIT
+34 IF N=QLEN
IF $ORDER(@CREF@(0))]""
Begin DoDot:2
+35 WRITE !,$CHAR(7)
+36 SET PROMPT=" -- ^"_OREF_" already exists!"
+37 IF DUZ(0)'="@"
SET %=0
WRITE !," ERROR"_PROMPT
+38 IF '$TEST
DO YN(" WARNING"_PROMPT_" --OK",.%)
End DoDot:2
End DoDot:1
if '%
QUIT
+39 QUIT
+40 ;
YN(PROMPT,%) ;Prompt yes/no
+1 NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
+2 SET DIR(0)="Y"
+3 if $GET(PROMPT)]""
SET DIR("A")=PROMPT
+4 SET DIR("B")="No"
+5 DO ^DIR
+6 SET %=Y=1
+7 QUIT
+8 ;
EN ; Enter here when the user is allowed to select his fields
+1 SET DIC=DIE
if DIC
SET DIC=$SELECT($DATA(^DIC(DIC,0,"GL")):^("GL"),1:"")
+2 if DIC]""
DO 1
KILL DIC
QUIT
+3 ;
SET1 ;
+1 IF $DATA(^VA(200,"AFOF"))
if '$DATA(^VA(200,DUZ,"FOF",0))
SET ^(0)="^200.032PA^"_+F_"^1"
SET ^(+F,0)=F_"^1^1^1^1^1^1"
+2 IF $DATA(^DIC(3,"AFOF"))
if '$DATA(^DIC(3,DUZ,"FOF",0))
SET ^(0)="^3.032PA^"_+F_"^1"
SET ^(+F,0)=F_"^1^1^1^1^1^1"
+3 SET DIK=$SELECT($DATA(^VA(200)):"^VA(200,DUZ,""FOF"",",1:"^DIC(3,DUZ,""FOF"",")
SET DA=F
SET DA(1)=DUZ
DO IX1^DIK
+4 QUIT
