DIKKUTL1 ;SFISC/MKO-KEY CREATION ;10:08 AM 12 Jan 2001 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**68**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
CREATE(DIKKTOP,DIKKFILE) ;Create a new key
N DIKKEY,DIKKFDA,DIKKNAME,DIKKIEN
;
;Prompt for name
S DIKKNAME=$$NAME(DIKKFILE) Q:DIKKNAME=-1
;
;Add new entry to Key file
W !," Creating new Key '"_DIKKNAME_"' ..."
S DIKKFDA(.31,"+1,",.01)=DIKKFILE
S DIKKFDA(.31,"+1,",.02)=DIKKNAME
S DIKKFDA(.31,"+1,",1)=$S($D(^DD("KEY","AP",DIKKFILE,"P")):"S",1:"P")
D UPDATE^DIE("","DIKKFDA","DIKKIEN") I $D(DIERR) D MSG^DIALOG() Q
;
S DIKKEY=DIKKIEN(1) K DIKKIEN
D EDIT^DIKKUTL(DIKKEY,DIKKTOP,DIKKFILE)
Q
;
UIMOD(DIXR,DIKKEY,DIKKTOP,DIKKFILE) ;Modify the UI to match the Key
N DIKKERR,DIKKFLD,DIKKFLIS,DIKKID,DIKKMSG,DIKKNEW,DIKKOLD
S DIKKID=$$KEYID(DIKKEY,DIKKTOP,DIKKFILE)
;
;Write message
W !!," Modifying Uniqueness Index ..."
;
;Get list of fields and original kill logic
D GETFLIST^DIKCUTL(DIXR,.DIKKFLIS)
D LOADXREF^DIKC1(DIKKFILE,"","K",DIXR,"","DIKKOLD")
;
;Get list of fields in key
D GETFLD(DIKKEY,.DIKKFLD)
;
;Stuff values into Uniqueness Index and fields into CRV multiple
D STUFF(DIXR,$P(^DD("IX",DIXR,0),U),DIKKFILE,$P(^(0),U,2),.DIKKFLD,DIKKID)
D DELCRV(DIXR)
D ADDCRV(DIXR,.DIKKFLD)
W " DONE!"
;
;Get list of fields and new set logic.
;Kill old and set new index, and recompile input templates and xrefs.
D GETFLIST^DIKCUTL(DIXR,.DIKKFLIS)
D LOADXREF^DIKC1(DIKKFILE,"","S",DIXR,"","DIKKNEW")
D KSC^DIKCUTL3(DIKKTOP,.DIKKOLD,.DIKKNEW,.DIKKFLIS)
Q
;
UICREATE(DIKKEY,DIKKTOP,DIKKFILE,DIKKNO) ;Create a new UI for key
;Returns DIKKNO=1 if the Index could not be created.
N DIERR,DIKKERR,DIKKFDA,DIKKFLIS,DIKKID,DIKKMSG,DIKKNAM,DIKKNEW,DIXR,I
;
K DIKKNO
S DIKKID=$$KEYID(DIKKEY,DIKKTOP,DIKKFILE)
;
;Write message
K DIKKMSG
S DIKKMSG(0)="I'm going to create a new Uniqueness Index to support "_DIKKID_"."
D WRAP^DIKCU2(.DIKKMSG)
W ! F I=0:1 Q:'$D(DIKKMSG(I)) W !,DIKKMSG(I)
K I,DIKKMSG
;
;Get Index Name and list of fields
S DIKKNAM=$$NAME^DIKCUTL1(DIKKFILE,"LS") I DIKKNAM=-1 S DIKKNO=1 Q
D GETFLD(DIKKEY,.DIKKFLD)
;
;Add uniqueness index to Index file, and fields into CRV multiple
D ADDUI(DIKKFILE,DIKKNAM,.DIXR) I DIXR=-1 S DIKKNO=1 Q
D STUFF(DIXR,DIKKFILE,DIKKFILE,DIKKNAM,.DIKKFLD,DIKKID)
D ADDCRV(DIXR,.DIKKFLD,.DIKKERR) I $G(DIKKERR) S DIKKNO=1 Q
;
;Set Uniqueness Index pointer in Key file
S DIKKFDA(.31,DIKKEY_",",3)=DIXR
D FILE^DIE("","DIKKFDA") I $D(DIERR) D MSG^DIALOG() S DIKKNO=1 Q
K DIKKFDA
;
;Get new field list and set logic.
;Set new index and recompile input templates and xrefs.
D GETFLIST^DIKCUTL(DIXR,.DIKKFLIS)
D LOADXREF^DIKC1(DIKKFILE,"","S",DIXR,"","DIKKNEW")
D KSC^DIKCUTL3(DIKKTOP,"",.DIKKNEW,.DIKKFLIS)
Q
;
ADDUI(DIKKFILE,DIKKNAM,DIXR) ;Add new entry to Index file
N DIKKFDA,DIKKIEN
W !!," One moment please ..."
S DIKKFDA(.11,"+1,",.01)=DIKKFILE
S DIKKFDA(.11,"+1,",.02)=DIKKNAM
D UPDATE^DIE("","DIKKFDA","DIKKIEN") I $D(DIERR) D MSG^DIALOG() Q
S DIXR=DIKKIEN(1)
Q
;
STUFF(DIXR,DIKKF01,DIKKFILE,DIKKNAM,DIKKFLD,DIKKID) ;Stuff other values into
;index
N DIERR,DIKKFDA,DIKKILL,DIKKSET,DIKKWKIL
;
;Build logic
D BLDLOG(DIKKF01,DIKKFILE,DIKKNAM,.DIKKFLD,.DIKKSET,.DIKKILL,.DIKKWKIL)
;
;Stuff values into other fields in Index file entry
S DIKKFDA(.11,DIXR_",",.11)="Uniqueness Index for "_DIKKID
S DIKKFDA(.11,DIXR_",",.2)="R"
S DIKKFDA(.11,DIXR_",",.4)=$S(DIKKFLD>1:"R",1:"F")
S DIKKFDA(.11,DIXR_",",.41)="IR"
S DIKKFDA(.11,DIXR_",",.42)="LS"
S DIKKFDA(.11,DIXR_",",.5)=$S(DIKKF01=DIKKFILE:"I",1:"W")
S DIKKFDA(.11,DIXR_",",.51)=DIKKFILE
S DIKKFDA(.11,DIXR_",",1.1)=DIKKSET
S DIKKFDA(.11,DIXR_",",2.1)=DIKKILL
S DIKKFDA(.11,DIXR_",",2.5)=DIKKWKIL
D FILE^DIE("","DIKKFDA")
I $D(DIERR) D MSG^DIALOG()
Q
;
ADDCRV(DIXR,DIKKFLD,DIKKERR) ;Add fields to Cross-Reference Values multiple
N DA,DD,DIC,DIERR,DIKKFDA,DIKKSS,DINUM,DO,X,Y
;
S DIC("P")=$P(^DD(.11,11.1,0),U,2)
F DIKKSS=1:1 Q:$D(DIKKFLD(DIKKSS))[0 D Q:$G(DIKKERR)
. ;Add subentry
. S DIC="^DD(""IX"","_DIXR_",11.1,",DIC(0)="QL",DA(1)=DIXR
. S (X,DINUM)=DIKKSS
. K DD,DO D FILE^DICN K DA,DIC,DINUM
. I Y=-1 S DIKKERR=1 Q
. ;
. ;Stuff other values
. S DIKKFDA(.114,DIKKSS_","_DIXR_",",.5)=DIKKSS
. S DIKKFDA(.114,DIKKSS_","_DIXR_",",1)="F"
. S DIKKFDA(.114,DIKKSS_","_DIXR_",",2)=$P(DIKKFLD(DIKKSS),U,2)
. S DIKKFDA(.114,DIKKSS_","_DIXR_",",3)=$P(DIKKFLD(DIKKSS),U)
. D FILE^DIE("","DIKKFDA")
. I $D(DIERR) D MSG^DIALOG() S DIKKERR=1
Q
;
DELCRV(DIXR) ;Delete all entries in CRV multiple
N DA,DIK
S DIK="^DD(""IX"","_DIXR_",11.1,",DA(1)=DIXR
S DA=0 F S DA=$O(^DD("IX",DIXR,11.1,DA)) Q:'DA D ^DIK
Q
;
GETFLD(KEY,FLD) ;Get list fields in key
;In:
; KEY = key #
;Out:
; FLD = # subscripts
; FLD(subscript#) = field^file
;
N DA,FD,FI,SQ
K FLD S (FLD,SQ)=0
F S SQ=$O(^DD("KEY",KEY,2,"S",SQ)) Q:'SQ D
. S FD=$O(^DD("KEY",KEY,2,"S",SQ,0)) Q:'FD
. S FI=$O(^DD("KEY",KEY,2,"S",SQ,FD,0)) Q:'FI
. S DA=$O(^DD("KEY",KEY,2,"S",SQ,FD,FI,0)) Q:'DA
. Q:$D(^DD("KEY",KEY,2,DA,0))[0
. S FLD=FLD+1,FLD(FLD)=FD_U_FI
Q
;
BLDLOG(DIKKF01,DIKKFILE,DIKKNAM,DIKKFLD,DIKKSET,DIKKILL,DIKKWKIL) ;
;Build the logic of the xref
N DIKKLDIF,DIKKROOT,DIKKSS,L
I 'DIKKFLD S (DIKKSET,DIKKILL)="Q",DIKKWKIL="" Q
;
;Build index root and entire kill logic
I DIKKF01'=DIKKFILE S DIKKLDIF=$$FLEVDIFF^DIKCU(DIKKF01,DIKKFILE)
E S DIKKLDIF=0
S DIKKROOT=$$FROOTDA^DIKCU(DIKKF01,DIKKLDIF_"O")_""""_DIKKNAM_""""
S DIKKWKIL="K "_DIKKROOT_")"
;
;Build root for set/kill logic
F DIKKSS=1:1 Q:$D(DIKKFLD(DIKKSS))[0 D
. S DIKKROOT=DIKKROOT_","_$S($G(DIKKFLD)=1:"X",1:"X("_DIKKSS_")")
;
;Append DA(n) to root
F L=DIKKLDIF:-1:1 S DIKKROOT=DIKKROOT_",DA("_L_")"
S DIKKROOT=DIKKROOT_",DA)"
;
;Build set/kill logic
S DIKKSET="S "_DIKKROOT_"=""""",DIKKILL="K "_DIKKROOT
Q
;
NAME(DIKKFILE) ;Get next available Key name
N DIKKNAME
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
;
S DIKKNAME=$O(^DD("KEY","BB",DIKKFILE,""),-1)
S DIKKNAME=$S(DIKKNAME="":"A",1:$C($A(DIKKNAME)+1))
;
S DIR(0)=".31,.02"
S DIR("A")="Enter a Name for the new Key"
S DIR("B")=DIKKNAME
W ! F D Q:$D(X)!$D(DIRUT)
. D ^DIR Q:$D(DIRUT)
. Q:'$D(^DD("KEY","BB",DIKKFILE,X))
. D NAMERR("A key already exists with this name.")
Q $S($D(DIRUT):-1,1:X)
;
NAMERR(MSG) ;Invalid Index Name error
W !!,$C(7)_$G(MSG),!
K X
Q
;
KEYID(KEY,TOP,FILE) ;Return string of text that identifies the key
Q "Key '"_$P(^DD("KEY",KEY,0),U,2)_"' of "_$S(TOP'=FILE:"Subf",1:"F")_"ile #"_$P(^(0),U)
;
DIKKUTL1 ;SFISC/MKO-KEY CREATION ;10:08 AM 12 Jan 2001 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**68**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
+4 ;
CREATE(DIKKTOP,DIKKFILE) ;Create a new key
+1 NEW DIKKEY,DIKKFDA,DIKKNAME,DIKKIEN
+2 ;
+3 ;Prompt for name
+4 SET DIKKNAME=$$NAME(DIKKFILE)
IF DIKKNAME=-1
QUIT
+5 ;
+6 ;Add new entry to Key file
+7 WRITE !," Creating new Key '"_DIKKNAME_"' ..."
+8 SET DIKKFDA(.31,"+1,",.01)=DIKKFILE
+9 SET DIKKFDA(.31,"+1,",.02)=DIKKNAME
+10 SET DIKKFDA(.31,"+1,",1)=$SELECT($DATA(^DD("KEY","AP",DIKKFILE,"P")):"S",1:"P")
+11 DO UPDATE^DIE("","DIKKFDA","DIKKIEN")
IF $DATA(DIERR)
DO MSG^DIALOG()
QUIT
+12 ;
+13 SET DIKKEY=DIKKIEN(1)
KILL DIKKIEN
+14 DO EDIT^DIKKUTL(DIKKEY,DIKKTOP,DIKKFILE)
+15 QUIT
+16 ;
UIMOD(DIXR,DIKKEY,DIKKTOP,DIKKFILE) ;Modify the UI to match the Key
+1 NEW DIKKERR,DIKKFLD,DIKKFLIS,DIKKID,DIKKMSG,DIKKNEW,DIKKOLD
+2 SET DIKKID=$$KEYID(DIKKEY,DIKKTOP,DIKKFILE)
+3 ;
+4 ;Write message
+5 WRITE !!," Modifying Uniqueness Index ..."
+6 ;
+7 ;Get list of fields and original kill logic
+8 DO GETFLIST^DIKCUTL(DIXR,.DIKKFLIS)
+9 DO LOADXREF^DIKC1(DIKKFILE,"","K",DIXR,"","DIKKOLD")
+10 ;
+11 ;Get list of fields in key
+12 DO GETFLD(DIKKEY,.DIKKFLD)
+13 ;
+14 ;Stuff values into Uniqueness Index and fields into CRV multiple
+15 DO STUFF(DIXR,$PIECE(^DD("IX",DIXR,0),U),DIKKFILE,$PIECE(^(0),U,2),.DIKKFLD,DIKKID)
+16 DO DELCRV(DIXR)
+17 DO ADDCRV(DIXR,.DIKKFLD)
+18 WRITE " DONE!"
+19 ;
+20 ;Get list of fields and new set logic.
+21 ;Kill old and set new index, and recompile input templates and xrefs.
+22 DO GETFLIST^DIKCUTL(DIXR,.DIKKFLIS)
+23 DO LOADXREF^DIKC1(DIKKFILE,"","S",DIXR,"","DIKKNEW")
+24 DO KSC^DIKCUTL3(DIKKTOP,.DIKKOLD,.DIKKNEW,.DIKKFLIS)
+25 QUIT
+26 ;
UICREATE(DIKKEY,DIKKTOP,DIKKFILE,DIKKNO) ;Create a new UI for key
+1 ;Returns DIKKNO=1 if the Index could not be created.
+2 NEW DIERR,DIKKERR,DIKKFDA,DIKKFLIS,DIKKID,DIKKMSG,DIKKNAM,DIKKNEW,DIXR,I
+3 ;
+4 KILL DIKKNO
+5 SET DIKKID=$$KEYID(DIKKEY,DIKKTOP,DIKKFILE)
+6 ;
+7 ;Write message
+8 KILL DIKKMSG
+9 SET DIKKMSG(0)="I'm going to create a new Uniqueness Index to support "_DIKKID_"."
+10 DO WRAP^DIKCU2(.DIKKMSG)
+11 WRITE !
FOR I=0:1
IF '$DATA(DIKKMSG(I))
QUIT
WRITE !,DIKKMSG(I)
+12 KILL I,DIKKMSG
+13 ;
+14 ;Get Index Name and list of fields
+15 SET DIKKNAM=$$NAME^DIKCUTL1(DIKKFILE,"LS")
IF DIKKNAM=-1
SET DIKKNO=1
QUIT
+16 DO GETFLD(DIKKEY,.DIKKFLD)
+17 ;
+18 ;Add uniqueness index to Index file, and fields into CRV multiple
+19 DO ADDUI(DIKKFILE,DIKKNAM,.DIXR)
IF DIXR=-1
SET DIKKNO=1
QUIT
+20 DO STUFF(DIXR,DIKKFILE,DIKKFILE,DIKKNAM,.DIKKFLD,DIKKID)
+21 DO ADDCRV(DIXR,.DIKKFLD,.DIKKERR)
IF $GET(DIKKERR)
SET DIKKNO=1
QUIT
+22 ;
+23 ;Set Uniqueness Index pointer in Key file
+24 SET DIKKFDA(.31,DIKKEY_",",3)=DIXR
+25 DO FILE^DIE("","DIKKFDA")
IF $DATA(DIERR)
DO MSG^DIALOG()
SET DIKKNO=1
QUIT
+26 KILL DIKKFDA
+27 ;
+28 ;Get new field list and set logic.
+29 ;Set new index and recompile input templates and xrefs.
+30 DO GETFLIST^DIKCUTL(DIXR,.DIKKFLIS)
+31 DO LOADXREF^DIKC1(DIKKFILE,"","S",DIXR,"","DIKKNEW")
+32 DO KSC^DIKCUTL3(DIKKTOP,"",.DIKKNEW,.DIKKFLIS)
+33 QUIT
+34 ;
ADDUI(DIKKFILE,DIKKNAM,DIXR) ;Add new entry to Index file
+1 NEW DIKKFDA,DIKKIEN
+2 WRITE !!," One moment please ..."
+3 SET DIKKFDA(.11,"+1,",.01)=DIKKFILE
+4 SET DIKKFDA(.11,"+1,",.02)=DIKKNAM
+5 DO UPDATE^DIE("","DIKKFDA","DIKKIEN")
IF $DATA(DIERR)
DO MSG^DIALOG()
QUIT
+6 SET DIXR=DIKKIEN(1)
+7 QUIT
+8 ;
STUFF(DIXR,DIKKF01,DIKKFILE,DIKKNAM,DIKKFLD,DIKKID) ;Stuff other values into
+1 ;index
+2 NEW DIERR,DIKKFDA,DIKKILL,DIKKSET,DIKKWKIL
+3 ;
+4 ;Build logic
+5 DO BLDLOG(DIKKF01,DIKKFILE,DIKKNAM,.DIKKFLD,.DIKKSET,.DIKKILL,.DIKKWKIL)
+6 ;
+7 ;Stuff values into other fields in Index file entry
+8 SET DIKKFDA(.11,DIXR_",",.11)="Uniqueness Index for "_DIKKID
+9 SET DIKKFDA(.11,DIXR_",",.2)="R"
+10 SET DIKKFDA(.11,DIXR_",",.4)=$SELECT(DIKKFLD>1:"R",1:"F")
+11 SET DIKKFDA(.11,DIXR_",",.41)="IR"
+12 SET DIKKFDA(.11,DIXR_",",.42)="LS"
+13 SET DIKKFDA(.11,DIXR_",",.5)=$SELECT(DIKKF01=DIKKFILE:"I",1:"W")
+14 SET DIKKFDA(.11,DIXR_",",.51)=DIKKFILE
+15 SET DIKKFDA(.11,DIXR_",",1.1)=DIKKSET
+16 SET DIKKFDA(.11,DIXR_",",2.1)=DIKKILL
+17 SET DIKKFDA(.11,DIXR_",",2.5)=DIKKWKIL
+18 DO FILE^DIE("","DIKKFDA")
+19 IF $DATA(DIERR)
DO MSG^DIALOG()
+20 QUIT
+21 ;
ADDCRV(DIXR,DIKKFLD,DIKKERR) ;Add fields to Cross-Reference Values multiple
+1 NEW DA,DD,DIC,DIERR,DIKKFDA,DIKKSS,DINUM,DO,X,Y
+2 ;
+3 SET DIC("P")=$PIECE(^DD(.11,11.1,0),U,2)
+4 FOR DIKKSS=1:1
IF $DATA(DIKKFLD(DIKKSS))[0
QUIT
Begin DoDot:1
+5 ;Add subentry
+6 SET DIC="^DD(""IX"","_DIXR_",11.1,"
SET DIC(0)="QL"
SET DA(1)=DIXR
+7 SET (X,DINUM)=DIKKSS
+8 KILL DD,DO
DO FILE^DICN
KILL DA,DIC,DINUM
+9 IF Y=-1
SET DIKKERR=1
QUIT
+10 ;
+11 ;Stuff other values
+12 SET DIKKFDA(.114,DIKKSS_","_DIXR_",",.5)=DIKKSS
+13 SET DIKKFDA(.114,DIKKSS_","_DIXR_",",1)="F"
+14 SET DIKKFDA(.114,DIKKSS_","_DIXR_",",2)=$PIECE(DIKKFLD(DIKKSS),U,2)
+15 SET DIKKFDA(.114,DIKKSS_","_DIXR_",",3)=$PIECE(DIKKFLD(DIKKSS),U)
+16 DO FILE^DIE("","DIKKFDA")
+17 IF $DATA(DIERR)
DO MSG^DIALOG()
SET DIKKERR=1
End DoDot:1
IF $GET(DIKKERR)
QUIT
+18 QUIT
+19 ;
DELCRV(DIXR) ;Delete all entries in CRV multiple
+1 NEW DA,DIK
+2 SET DIK="^DD(""IX"","_DIXR_",11.1,"
SET DA(1)=DIXR
+3 SET DA=0
FOR
SET DA=$ORDER(^DD("IX",DIXR,11.1,DA))
IF 'DA
QUIT
DO ^DIK
+4 QUIT
+5 ;
GETFLD(KEY,FLD) ;Get list fields in key
+1 ;In:
+2 ; KEY = key #
+3 ;Out:
+4 ; FLD = # subscripts
+5 ; FLD(subscript#) = field^file
+6 ;
+7 NEW DA,FD,FI,SQ
+8 KILL FLD
SET (FLD,SQ)=0
+9 FOR
SET SQ=$ORDER(^DD("KEY",KEY,2,"S",SQ))
IF 'SQ
QUIT
Begin DoDot:1
+10 SET FD=$ORDER(^DD("KEY",KEY,2,"S",SQ,0))
IF 'FD
QUIT
+11 SET FI=$ORDER(^DD("KEY",KEY,2,"S",SQ,FD,0))
IF 'FI
QUIT
+12 SET DA=$ORDER(^DD("KEY",KEY,2,"S",SQ,FD,FI,0))
IF 'DA
QUIT
+13 IF $DATA(^DD("KEY",KEY,2,DA,0))[0
QUIT
+14 SET FLD=FLD+1
SET FLD(FLD)=FD_U_FI
End DoDot:1
+15 QUIT
+16 ;
BLDLOG(DIKKF01,DIKKFILE,DIKKNAM,DIKKFLD,DIKKSET,DIKKILL,DIKKWKIL) ;
+1 ;Build the logic of the xref
+2 NEW DIKKLDIF,DIKKROOT,DIKKSS,L
+3 IF 'DIKKFLD
SET (DIKKSET,DIKKILL)="Q"
SET DIKKWKIL=""
QUIT
+4 ;
+5 ;Build index root and entire kill logic
+6 IF DIKKF01'=DIKKFILE
SET DIKKLDIF=$$FLEVDIFF^DIKCU(DIKKF01,DIKKFILE)
+7 IF '$TEST
SET DIKKLDIF=0
+8 SET DIKKROOT=$$FROOTDA^DIKCU(DIKKF01,DIKKLDIF_"O")_""""_DIKKNAM_""""
+9 SET DIKKWKIL="K "_DIKKROOT_")"
+10 ;
+11 ;Build root for set/kill logic
+12 FOR DIKKSS=1:1
IF $DATA(DIKKFLD(DIKKSS))[0
QUIT
Begin DoDot:1
+13 SET DIKKROOT=DIKKROOT_","_$SELECT($GET(DIKKFLD)=1:"X",1:"X("_DIKKSS_")")
End DoDot:1
+14 ;
+15 ;Append DA(n) to root
+16 FOR L=DIKKLDIF:-1:1
SET DIKKROOT=DIKKROOT_",DA("_L_")"
+17 SET DIKKROOT=DIKKROOT_",DA)"
+18 ;
+19 ;Build set/kill logic
+20 SET DIKKSET="S "_DIKKROOT_"="""""
SET DIKKILL="K "_DIKKROOT
+21 QUIT
+22 ;
NAME(DIKKFILE) ;Get next available Key name
+1 NEW DIKKNAME
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 ;
+4 SET DIKKNAME=$ORDER(^DD("KEY","BB",DIKKFILE,""),-1)
+5 SET DIKKNAME=$SELECT(DIKKNAME="":"A",1:$CHAR($ASCII(DIKKNAME)+1))
+6 ;
+7 SET DIR(0)=".31,.02"
+8 SET DIR("A")="Enter a Name for the new Key"
+9 SET DIR("B")=DIKKNAME
+10 WRITE !
FOR
Begin DoDot:1
+11 DO ^DIR
IF $DATA(DIRUT)
QUIT
+12 IF '$DATA(^DD("KEY","BB",DIKKFILE,X))
QUIT
+13 DO NAMERR("A key already exists with this name.")
End DoDot:1
IF $DATA(X)!$DATA(DIRUT)
QUIT
+14 QUIT $SELECT($DATA(DIRUT):-1,1:X)
+15 ;
NAMERR(MSG) ;Invalid Index Name error
+1 WRITE !!,$CHAR(7)_$GET(MSG),!
+2 KILL X
+3 QUIT
+4 ;
KEYID(KEY,TOP,FILE) ;Return string of text that identifies the key
+1 QUIT "Key '"_$PIECE(^DD("KEY",KEY,0),U,2)_"' of "_$SELECT(TOP'=FILE:"Subf",1:"F")_"ile #"_$PIECE(^(0),U)
+2 ;
