DIKCUTL1 ;SFISC/MKO-UTILITY OPTION TO MODIFY INDEX ;9:10 AM 7 Aug 2001
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
CREATE(DIKCTOP,DIKCFILE) ;Create a new index
N DIKCF01,DIKCFLIS,DIKCNAME,DIKCNEW,DIKCTLIS,DIKCTYPE,DIKCUSE,DIXR
N DA,DDSFILE,DR
;
;Get Type, File, Use, and Name
S DIKCTYPE=$$TYPE Q:DIKCTYPE=-1
S DIKCF01=$$FILE01(DIKCTOP,DIKCFILE) Q:DIKCF01=-1
S DIKCUSE=$$USE(DIKCTYPE) Q:DIKCUSE=-1
S DIKCNAME=$$NAME(DIKCF01,DIKCUSE) Q:DIKCNAME=-1
;
;Create the new index in the Index file
D ADD(DIKCF01,DIKCFILE,DIKCNAME,DIKCTYPE,DIKCUSE,.DIXR) Q:DIXR=-1
;
;Invoke form to edit index, quit if deleted,
;delete if no short description
S DDSFILE=.11,DA=DIXR,DR="[DIKC EDIT]" D ^DDS K DDSFILE,DA,DR
Q:$D(^DD("IX",DIXR,0))[0
I $P($G(^DD("IX",DIXR,0)),U,3)="" D Q
. N DIK,DA
. S DIK="^DD(""IX"",",DA=DIXR D ^DIK
. W !!," Index definition deleted."
;
;Get new fields list and set logic.
;Modify the trigger logic of fields that trigger fields in the index
;Set new index, recompile input templates and xrefs.
D GETFLIST^DIKCUTL(DIXR,.DIKCFLIS)
K DIKCTLIS D TRIG^DICR(.DIKCFLIS,.DIKCTLIS)
D:$D(DIKCTLIS) DIEZ^DIKCUTL3(" ",.DIKCTLIS)
D LOADXREF^DIKC1(DIKCFILE,"","S",DIXR,"","DIKCNEW")
D KSC^DIKCUTL3(DIKCTOP,"",.DIKCNEW,.DIKCFLIS)
Q
;
TYPE() ;Prompt for index type (regular or MUMPS)
N DIKCTYPE,DIR,DIROUT,DIRUT,DTOUT,X,Y
;
S DIR(0)=".11,.2",DIR("A")="Type of index",DIR("B")="REGULAR"
F D Q:$D(DIRUT)!$D(DIKCTYPE)
. W ! D ^DIR Q:$D(DIRUT)
. I Y="MU",$G(DUZ(0))'="@" D
.. W !,$C(7)_"Only programmers can create MUMPS cross references."
. E I Y="MU",$P($G(^DD(DIKCTOP,0,"DI")),U)="Y" D
.. W !,$C(7)_"Cannot create MUMPS cross references on archived files."
. E S DIKCTYPE=Y
;
Q $S($D(DIRUT):-1,1:DIKCTYPE)
;
FILE01(DIKCTOP,DIKCFILE) ;Return file on which to store xref
;If DIKCFILE is not a subfile, return that file #
I DIKCTOP=DIKCFILE Q DIKCFILE
;
;Otherwise, prompt for file on which to store xref
N FILE01,FINFO,LEV
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
;
;Get info on subfile DICKFILE
D FINFO^DIKCU1(DIKCFILE,.FINFO)
;
;Prompt for whether whole file indexes should be created
W !
S DIR(0)="Y",DIR("B")="Yes"
S DIR("?")=" Enter 'Yes' if you want the index to reside at this level."
F LEV=0:1:$O(FINFO(""),-1)-1 D Q:$D(DIRUT)!$D(FILE01)
. S DIR("A")="Want to index whole "_$S(LEV:"sub",1:"")_"file "_$P(FINFO(LEV),U,3)_" (#"_$P(FINFO(LEV),U)_")"
. D ^DIR Q:$D(DIRUT)!'Y
. S FILE01=$P(FINFO(LEV),U)
;
Q $S($D(DIRUT):-1,'$D(FILE01):DIKCFILE,1:FILE01)
;
USE(DIKCTYPE) ;Prompt for Use (Lookup or Lookup & Sorting)
;DIKCTYPE = type of index
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)=".11,.42"
I $G(DIKCTYPE)="MU" D
. S DIR("A")="How is this MUMPS cross reference to be used"
. S DIR("B")="ACTION"
E D
. S DIR("A",1)="Want index to be used for Lookup & Sorting"
. S DIR("A")=" or Sorting Only"
. S DIR("B")="LOOKUP & SORTING"
. S DIR(0)=DIR(0)_"^^I X=""A"" W !!,$C(7)_""** Only MUMPS cross references can be ACTION-type cross references. **"" K X"
W ! D ^DIR K DIR
Q $S($D(DTOUT)!$D(DUOUT):-1,1:Y)
;
NAME(DIKCF01,DIKCUSE) ;Get next available index name
N DIKCASC,DIKCNAME,DIKCSTRT
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
;
;Get next available index name
S DIKCSTRT=$S(DIKCUSE="LS":"",1:"A")
F DIKCASC=67:1 D Q:DIKCNAME]""
. S DIKCNAME=DIKCSTRT_$C(DIKCASC)
. I $D(^DD("IX","BB",DIKCF01,DIKCNAME)) S DIKCNAME="" Q
. I $D(^DD(DIKCF01,0,"IX",DIKCNAME)) S DIKCNAME="" Q
;
;If not a programmer, return next available index name
Q:DUZ(0)'="@" DIKCNAME
;
;Otherwise, prompt for index name
W !
S DIR(0)=".11,.02"
S DIR("A")="Index Name",DIR("B")=DIKCNAME
F D Q:$D(X)!$D(DIRUT)
. D ^DIR Q:$D(DIRUT)
. ;
. ;Check response; print message and kill X if invalid
. I DIKCUSE="LS",$E(X)="A" D Q
.. D NAMERR("Indexes used for Lookup & Sorting cannot start with 'A'")
. I DIKCUSE="S",$E(X)'="A" D Q
.. D NAMERR("Indexes used for Sorting Only must start with 'A'")
. I DIKCUSE="A",$E(X)'="A" D Q
.. D NAMERR("Action-type indexes must start with 'A'")
. I $D(^DD("IX","BB",DIKCF01,X)) D Q
.. D NAMERR("There is already an index defined with this name.")
. I $D(^DD(DIKCF01,0,"IX",X)) D Q
.. D NAMERR("There is already a cross-reference defined with this name.") Q
;
Q $S($D(DIRUT):-1,1:X)
;
NAMERR(MSG) ;Invalid index name error
W !!,$C(7)_$G(MSG),!
K X
Q
;
ADD(DIKCF01,DIKCFILE,DIKCNAME,DIKCTYPE,DIKCUSE,DIXR) ;
;Add new entry to Index file
;Returns DIXR=-1 if error
N DIKCFDA,DIKCIEN
S DIKCFDA(.11,"+1,",.01)=DIKCF01
S DIKCFDA(.11,"+1,",.02)=DIKCNAME
S DIKCFDA(.11,"+1,",.2)=DIKCTYPE
S DIKCFDA(.11,"+1,",.4)="F"
S DIKCFDA(.11,"+1,",.41)="IR"
S:$G(DIKCUSE)]"" DIKCFDA(.11,"+1,",.42)=DIKCUSE
S DIKCFDA(.11,"+1,",.5)=$S(DIKCF01=DIKCFILE:"I",1:"W")
S DIKCFDA(.11,"+1,",.51)=DIKCFILE
S DIKCFDA(.11,"+1,",1.1)="Q"
S DIKCFDA(.11,"+1,",2.1)="Q"
D UPDATE^DIE("","DIKCFDA","DIKCIEN")
I '$D(DIERR) S DIXR=DIKCIEN(1)
E D MSG^DIALOG() S DIXR=-1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKCUTL1 5365 printed Dec 13, 2024@02:48:54 Page 2
DIKCUTL1 ;SFISC/MKO-UTILITY OPTION TO MODIFY INDEX ;9:10 AM 7 Aug 2001
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
CREATE(DIKCTOP,DIKCFILE) ;Create a new index
+1 NEW DIKCF01,DIKCFLIS,DIKCNAME,DIKCNEW,DIKCTLIS,DIKCTYPE,DIKCUSE,DIXR
+2 NEW DA,DDSFILE,DR
+3 ;
+4 ;Get Type, File, Use, and Name
+5 SET DIKCTYPE=$$TYPE
if DIKCTYPE=-1
QUIT
+6 SET DIKCF01=$$FILE01(DIKCTOP,DIKCFILE)
if DIKCF01=-1
QUIT
+7 SET DIKCUSE=$$USE(DIKCTYPE)
if DIKCUSE=-1
QUIT
+8 SET DIKCNAME=$$NAME(DIKCF01,DIKCUSE)
if DIKCNAME=-1
QUIT
+9 ;
+10 ;Create the new index in the Index file
+11 DO ADD(DIKCF01,DIKCFILE,DIKCNAME,DIKCTYPE,DIKCUSE,.DIXR)
if DIXR=-1
QUIT
+12 ;
+13 ;Invoke form to edit index, quit if deleted,
+14 ;delete if no short description
+15 SET DDSFILE=.11
SET DA=DIXR
SET DR="[DIKC EDIT]"
DO ^DDS
KILL DDSFILE,DA,DR
+16 if $DATA(^DD("IX",DIXR,0))[0
QUIT
+17 IF $PIECE($GET(^DD("IX",DIXR,0)),U,3)=""
Begin DoDot:1
+18 NEW DIK,DA
+19 SET DIK="^DD(""IX"","
SET DA=DIXR
DO ^DIK
+20 WRITE !!," Index definition deleted."
End DoDot:1
QUIT
+21 ;
+22 ;Get new fields list and set logic.
+23 ;Modify the trigger logic of fields that trigger fields in the index
+24 ;Set new index, recompile input templates and xrefs.
+25 DO GETFLIST^DIKCUTL(DIXR,.DIKCFLIS)
+26 KILL DIKCTLIS
DO TRIG^DICR(.DIKCFLIS,.DIKCTLIS)
+27 if $DATA(DIKCTLIS)
DO DIEZ^DIKCUTL3(" ",.DIKCTLIS)
+28 DO LOADXREF^DIKC1(DIKCFILE,"","S",DIXR,"","DIKCNEW")
+29 DO KSC^DIKCUTL3(DIKCTOP,"",.DIKCNEW,.DIKCFLIS)
+30 QUIT
+31 ;
TYPE() ;Prompt for index type (regular or MUMPS)
+1 NEW DIKCTYPE,DIR,DIROUT,DIRUT,DTOUT,X,Y
+2 ;
+3 SET DIR(0)=".11,.2"
SET DIR("A")="Type of index"
SET DIR("B")="REGULAR"
+4 FOR
Begin DoDot:1
+5 WRITE !
DO ^DIR
if $DATA(DIRUT)
QUIT
+6 IF Y="MU"
IF $GET(DUZ(0))'="@"
Begin DoDot:2
+7 WRITE !,$CHAR(7)_"Only programmers can create MUMPS cross references."
End DoDot:2
+8 IF '$TEST
IF Y="MU"
IF $PIECE($GET(^DD(DIKCTOP,0,"DI")),U)="Y"
Begin DoDot:2
+9 WRITE !,$CHAR(7)_"Cannot create MUMPS cross references on archived files."
End DoDot:2
+10 IF '$TEST
SET DIKCTYPE=Y
End DoDot:1
if $DATA(DIRUT)!$DATA(DIKCTYPE)
QUIT
+11 ;
+12 QUIT $SELECT($DATA(DIRUT):-1,1:DIKCTYPE)
+13 ;
FILE01(DIKCTOP,DIKCFILE) ;Return file on which to store xref
+1 ;If DIKCFILE is not a subfile, return that file #
+2 IF DIKCTOP=DIKCFILE
QUIT DIKCFILE
+3 ;
+4 ;Otherwise, prompt for file on which to store xref
+5 NEW FILE01,FINFO,LEV
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+7 ;
+8 ;Get info on subfile DICKFILE
+9 DO FINFO^DIKCU1(DIKCFILE,.FINFO)
+10 ;
+11 ;Prompt for whether whole file indexes should be created
+12 WRITE !
+13 SET DIR(0)="Y"
SET DIR("B")="Yes"
+14 SET DIR("?")=" Enter 'Yes' if you want the index to reside at this level."
+15 FOR LEV=0:1:$ORDER(FINFO(""),-1)-1
Begin DoDot:1
+16 SET DIR("A")="Want to index whole "_$SELECT(LEV:"sub",1:"")_"file "_$PIECE(FINFO(LEV),U,3)_" (#"_$PIECE(FINFO(LEV),U)_")"
+17 DO ^DIR
if $DATA(DIRUT)!'Y
QUIT
+18 SET FILE01=$PIECE(FINFO(LEV),U)
End DoDot:1
if $DATA(DIRUT)!$DATA(FILE01)
QUIT
+19 ;
+20 QUIT $SELECT($DATA(DIRUT):-1,'$DATA(FILE01):DIKCFILE,1:FILE01)
+21 ;
USE(DIKCTYPE) ;Prompt for Use (Lookup or Lookup & Sorting)
+1 ;DIKCTYPE = type of index
+2 ;
+3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+4 SET DIR(0)=".11,.42"
+5 IF $GET(DIKCTYPE)="MU"
Begin DoDot:1
+6 SET DIR("A")="How is this MUMPS cross reference to be used"
+7 SET DIR("B")="ACTION"
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET DIR("A",1)="Want index to be used for Lookup & Sorting"
+10 SET DIR("A")=" or Sorting Only"
+11 SET DIR("B")="LOOKUP & SORTING"
+12 SET DIR(0)=DIR(0)_"^^I X=""A"" W !!,$C(7)_""** Only MUMPS cross references can be ACTION-type cross references. **"" K X"
End DoDot:1
+13 WRITE !
DO ^DIR
KILL DIR
+14 QUIT $SELECT($DATA(DTOUT)!$DATA(DUOUT):-1,1:Y)
+15 ;
NAME(DIKCF01,DIKCUSE) ;Get next available index name
+1 NEW DIKCASC,DIKCNAME,DIKCSTRT
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 ;
+4 ;Get next available index name
+5 SET DIKCSTRT=$SELECT(DIKCUSE="LS":"",1:"A")
+6 FOR DIKCASC=67:1
Begin DoDot:1
+7 SET DIKCNAME=DIKCSTRT_$CHAR(DIKCASC)
+8 IF $DATA(^DD("IX","BB",DIKCF01,DIKCNAME))
SET DIKCNAME=""
QUIT
+9 IF $DATA(^DD(DIKCF01,0,"IX",DIKCNAME))
SET DIKCNAME=""
QUIT
End DoDot:1
if DIKCNAME]""
QUIT
+10 ;
+11 ;If not a programmer, return next available index name
+12 if DUZ(0)'="@"
QUIT DIKCNAME
+13 ;
+14 ;Otherwise, prompt for index name
+15 WRITE !
+16 SET DIR(0)=".11,.02"
+17 SET DIR("A")="Index Name"
SET DIR("B")=DIKCNAME
+18 FOR
Begin DoDot:1
+19 DO ^DIR
if $DATA(DIRUT)
QUIT
+20 ;
+21 ;Check response; print message and kill X if invalid
+22 IF DIKCUSE="LS"
IF $EXTRACT(X)="A"
Begin DoDot:2
+23 DO NAMERR("Indexes used for Lookup & Sorting cannot start with 'A'")
End DoDot:2
QUIT
+24 IF DIKCUSE="S"
IF $EXTRACT(X)'="A"
Begin DoDot:2
+25 DO NAMERR("Indexes used for Sorting Only must start with 'A'")
End DoDot:2
QUIT
+26 IF DIKCUSE="A"
IF $EXTRACT(X)'="A"
Begin DoDot:2
+27 DO NAMERR("Action-type indexes must start with 'A'")
End DoDot:2
QUIT
+28 IF $DATA(^DD("IX","BB",DIKCF01,X))
Begin DoDot:2
+29 DO NAMERR("There is already an index defined with this name.")
End DoDot:2
QUIT
+30 IF $DATA(^DD(DIKCF01,0,"IX",X))
Begin DoDot:2
+31 DO NAMERR("There is already a cross-reference defined with this name.")
QUIT
End DoDot:2
QUIT
End DoDot:1
if $DATA(X)!$DATA(DIRUT)
QUIT
+32 ;
+33 QUIT $SELECT($DATA(DIRUT):-1,1:X)
+34 ;
NAMERR(MSG) ;Invalid index name error
+1 WRITE !!,$CHAR(7)_$GET(MSG),!
+2 KILL X
+3 QUIT
+4 ;
ADD(DIKCF01,DIKCFILE,DIKCNAME,DIKCTYPE,DIKCUSE,DIXR) ;
+1 ;Add new entry to Index file
+2 ;Returns DIXR=-1 if error
+3 NEW DIKCFDA,DIKCIEN
+4 SET DIKCFDA(.11,"+1,",.01)=DIKCF01
+5 SET DIKCFDA(.11,"+1,",.02)=DIKCNAME
+6 SET DIKCFDA(.11,"+1,",.2)=DIKCTYPE
+7 SET DIKCFDA(.11,"+1,",.4)="F"
+8 SET DIKCFDA(.11,"+1,",.41)="IR"
+9 if $GET(DIKCUSE)]""
SET DIKCFDA(.11,"+1,",.42)=DIKCUSE
+10 SET DIKCFDA(.11,"+1,",.5)=$SELECT(DIKCF01=DIKCFILE:"I",1:"W")
+11 SET DIKCFDA(.11,"+1,",.51)=DIKCFILE
+12 SET DIKCFDA(.11,"+1,",1.1)="Q"
+13 SET DIKCFDA(.11,"+1,",2.1)="Q"
+14 DO UPDATE^DIE("","DIKCFDA","DIKCIEN")
+15 IF '$DATA(DIERR)
SET DIXR=DIKCIEN(1)
+16 IF '$TEST
DO MSG^DIALOG()
SET DIXR=-1
+17 QUIT
