DIKCUTL ;SFISC/MKO-UTILITY OPTION TO MODIFY INDEX ;26MAR2010
;;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.
;
MOD ;Utility option to modify an index
N DIKCCNT,DIKCFILE,DIKCQUIT,DIKCROOT,DIKCTOP,DIXR
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
;
;Prompt for file
D SELFILE^DIKCU(.DIKCROOT,.DIKCTOP,.DIKCFILE)
Q:$G(DIKCROOT)="" Q:'$G(DIKCTOP)
S:'$G(DIKCFILE) DIKCFILE=DIKCTOP
;
REMOD ;Get and list indexes
I $G(DIKCQUIT) W ! Q
D GETXR^DIKCUTL2(DIKCFILE,.DIKCCNT)
W ! D LIST^DIKCUTL2(.DIKCCNT)
;
;Prompt for action
I 'DIKCCNT S Y="C"
E D RD^DICD I $D(DIRUT) W ! Q
;
;Delete
I Y="D" D G REMOD
. S DIXR=$$CHOOSE^DIKCUTL2(.DIKCCNT,"delete") Q:'DIXR
NODELETE . I $D(^DD("IX",DIXR,666)) W !?5,$C(7),"This Index cannot be deleted.",! S DIXR=0 Q ;**GFT
. I $D(^DD("KEY","AU",DIXR)) W ! D PRTMSG^DIKCUTL2(DIXR) Q
. S DIR(0)="Y"
. S DIR("A")="Are you sure you want to delete the index definition"
. S DIR("B")="NO"
. D ^DIR K DIR Q:$D(DIRUT)!'Y
. D DELETE(DIXR,DIKCTOP,DIKCFILE)
;
;Edit
I Y="E" D G REMOD
. S DIXR=$$CHOOSE^DIKCUTL2(.DIKCCNT,"edit") Q:'DIXR
. D EDIT(DIXR,DIKCTOP,DIKCFILE)
;
;Create
I Y="C" D G REMOD
. S DIR(0)="Y",DIR("B")="No"
. S DIR("A")="Want to create a new index for this file"
. D ^DIR K DIR I $D(DIRUT)!'Y S:'DIKCCNT DIKCQUIT=1 Q
. D CREATE^DIKCUTL1(DIKCTOP,DIKCFILE)
Q
;
DELETE(DIXR,DIKCTOP,DIKCFILE) ;Delete an index
N DA,DIK,DIKCFLIS,DIKCOLD
D GETFLIST(DIXR,.DIKCFLIS)
D LOADXREF^DIKC1(DIKCFILE,"","K",DIXR,"","DIKCOLD")
;
;Delete the index
S DIK="^DD(""IX"",",DA=DIXR D ^DIK K DIK,DA
W !!," Index definition deleted."
;
;Run kill logic, recompile
D KSC^DIKCUTL3(DIKCTOP,.DIKCOLD,"",.DIKCFLIS)
Q
;
EDIT(DIXR,DIKCTOP,DIKCFILE) ;Edit an index
N DA,DDSCHANG,DDSFILE,DDSPARM,DR
N DIKCFLIS,DIKCNEW,DIKCOLD,DIKCREB
;
;Save original fields list and logic
D GETFLIST(DIXR,.DIKCFLIS)
D LOADXREF^DIKC1(DIKCFILE,"","KS",DIXR,"","DIKCOLD")
;
;Invoke form to edit, quit if there were no changes
S DDSFILE=.11,DA=DIXR,DDSPARM="C"
S DR="[DIKC EDIT"_$S($D(^DD("KEY","AU",DIXR)):" UI]",1:"]")
D ^DDS Q:'$G(DDSCHANG) K DDSFILE,DA,DDSPARM,DR
;
;If index was deleted, run kill logic, recompile and quit
I $D(^DD("IX",DIXR,0))[0 D Q
. K DIKCOLD(DIKCFILE,DIXR,"S"),DIKCOLD(DIKCFILE,DIXR,"SC")
. D KSC^DIKCUTL3(DIKCTOP,.DIKCOLD,"",.DIKCFLIS)
;
;Rebuild the set/kill logic if a crv was deleted,
;but form was not saved.
;Deleting a crv sets DIKCREB; saving the form, kills it.
D:$G(DIKCREB) BLDLOG^DIKCUTL2(DIXR)
;
;Load new logic; quit if equal to old logic
D LOADXREF^DIKC1(DIKCFILE,"","KS",DIXR,"","DIKCNEW")
Q:$$GCMP^DIKCU2("DIKCOLD","DIKCNEW")
;
;Run old kill logic and new set logic.
;Add new fields to list, and recompile input templates and xrefs.
D GETFLIST(DIXR,.DIKCFLIS)
K DIKCOLD(DIKCFILE,DIXR,"S"),DIKCOLD(DIKCFILE,DIXR,"SC")
D KSC^DIKCUTL3(DIKCTOP,.DIKCOLD,.DIKCNEW,.DIKCFLIS)
Q
;
;============================
;GETFLIST(index#,.fieldList)
;============================
;Loop through Cross Reference Values multiple and
;build list of fields used in Index XR. (Existing items in fieldList
;array are NOT deleted.)
;In:
; XR = Index ien
;Out:
; FLIST(file#,field#) = ""
;
GETFLIST(XR,FLIST) ;
N FIL,FLD,I
S I=0 F S I=$O(^DD("IX",XR,11.1,I)) Q:'I D
. Q:$P($G(^DD("IX",XR,11.1,I,0)),U,2)'="F"
. S FIL=$P(^DD("IX",XR,11.1,I,0),U,3),FLD=$P(^(0),U,4) Q:'FIL Q:'FLD
. S FLIST(FIL,FLD)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKCUTL 3764 printed Sep 23, 2025@20:24:59 Page 2
DIKCUTL ;SFISC/MKO-UTILITY OPTION TO MODIFY INDEX ;26MAR2010
+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 ;
MOD ;Utility option to modify an index
+1 NEW DIKCCNT,DIKCFILE,DIKCQUIT,DIKCROOT,DIKCTOP,DIXR
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 ;
+4 ;Prompt for file
+5 DO SELFILE^DIKCU(.DIKCROOT,.DIKCTOP,.DIKCFILE)
+6 if $GET(DIKCROOT)=""
QUIT
if '$GET(DIKCTOP)
QUIT
+7 if '$GET(DIKCFILE)
SET DIKCFILE=DIKCTOP
+8 ;
REMOD ;Get and list indexes
+1 IF $GET(DIKCQUIT)
WRITE !
QUIT
+2 DO GETXR^DIKCUTL2(DIKCFILE,.DIKCCNT)
+3 WRITE !
DO LIST^DIKCUTL2(.DIKCCNT)
+4 ;
+5 ;Prompt for action
+6 IF 'DIKCCNT
SET Y="C"
+7 IF '$TEST
DO RD^DICD
IF $DATA(DIRUT)
WRITE !
QUIT
+8 ;
+9 ;Delete
+10 IF Y="D"
Begin DoDot:1
+11 SET DIXR=$$CHOOSE^DIKCUTL2(.DIKCCNT,"delete")
if 'DIXR
QUIT
NODELETE ;**GFT
IF $DATA(^DD("IX",DIXR,666))
WRITE !?5,$CHAR(7),"This Index cannot be deleted.",!
SET DIXR=0
QUIT
+1 IF $DATA(^DD("KEY","AU",DIXR))
WRITE !
DO PRTMSG^DIKCUTL2(DIXR)
QUIT
+2 SET DIR(0)="Y"
+3 SET DIR("A")="Are you sure you want to delete the index definition"
+4 SET DIR("B")="NO"
+5 DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
QUIT
+6 DO DELETE(DIXR,DIKCTOP,DIKCFILE)
End DoDot:1
GOTO REMOD
+7 ;
+8 ;Edit
+9 IF Y="E"
Begin DoDot:1
+10 SET DIXR=$$CHOOSE^DIKCUTL2(.DIKCCNT,"edit")
if 'DIXR
QUIT
+11 DO EDIT(DIXR,DIKCTOP,DIKCFILE)
End DoDot:1
GOTO REMOD
+12 ;
+13 ;Create
+14 IF Y="C"
Begin DoDot:1
+15 SET DIR(0)="Y"
SET DIR("B")="No"
+16 SET DIR("A")="Want to create a new index for this file"
+17 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!'Y
if 'DIKCCNT
SET DIKCQUIT=1
QUIT
+18 DO CREATE^DIKCUTL1(DIKCTOP,DIKCFILE)
End DoDot:1
GOTO REMOD
+19 QUIT
+20 ;
DELETE(DIXR,DIKCTOP,DIKCFILE) ;Delete an index
+1 NEW DA,DIK,DIKCFLIS,DIKCOLD
+2 DO GETFLIST(DIXR,.DIKCFLIS)
+3 DO LOADXREF^DIKC1(DIKCFILE,"","K",DIXR,"","DIKCOLD")
+4 ;
+5 ;Delete the index
+6 SET DIK="^DD(""IX"","
SET DA=DIXR
DO ^DIK
KILL DIK,DA
+7 WRITE !!," Index definition deleted."
+8 ;
+9 ;Run kill logic, recompile
+10 DO KSC^DIKCUTL3(DIKCTOP,.DIKCOLD,"",.DIKCFLIS)
+11 QUIT
+12 ;
EDIT(DIXR,DIKCTOP,DIKCFILE) ;Edit an index
+1 NEW DA,DDSCHANG,DDSFILE,DDSPARM,DR
+2 NEW DIKCFLIS,DIKCNEW,DIKCOLD,DIKCREB
+3 ;
+4 ;Save original fields list and logic
+5 DO GETFLIST(DIXR,.DIKCFLIS)
+6 DO LOADXREF^DIKC1(DIKCFILE,"","KS",DIXR,"","DIKCOLD")
+7 ;
+8 ;Invoke form to edit, quit if there were no changes
+9 SET DDSFILE=.11
SET DA=DIXR
SET DDSPARM="C"
+10 SET DR="[DIKC EDIT"_$SELECT($DATA(^DD("KEY","AU",DIXR)):" UI]",1:"]")
+11 DO ^DDS
if '$GET(DDSCHANG)
QUIT
KILL DDSFILE,DA,DDSPARM,DR
+12 ;
+13 ;If index was deleted, run kill logic, recompile and quit
+14 IF $DATA(^DD("IX",DIXR,0))[0
Begin DoDot:1
+15 KILL DIKCOLD(DIKCFILE,DIXR,"S"),DIKCOLD(DIKCFILE,DIXR,"SC")
+16 DO KSC^DIKCUTL3(DIKCTOP,.DIKCOLD,"",.DIKCFLIS)
End DoDot:1
QUIT
+17 ;
+18 ;Rebuild the set/kill logic if a crv was deleted,
+19 ;but form was not saved.
+20 ;Deleting a crv sets DIKCREB; saving the form, kills it.
+21 if $GET(DIKCREB)
DO BLDLOG^DIKCUTL2(DIXR)
+22 ;
+23 ;Load new logic; quit if equal to old logic
+24 DO LOADXREF^DIKC1(DIKCFILE,"","KS",DIXR,"","DIKCNEW")
+25 if $$GCMP^DIKCU2("DIKCOLD","DIKCNEW")
QUIT
+26 ;
+27 ;Run old kill logic and new set logic.
+28 ;Add new fields to list, and recompile input templates and xrefs.
+29 DO GETFLIST(DIXR,.DIKCFLIS)
+30 KILL DIKCOLD(DIKCFILE,DIXR,"S"),DIKCOLD(DIKCFILE,DIXR,"SC")
+31 DO KSC^DIKCUTL3(DIKCTOP,.DIKCOLD,.DIKCNEW,.DIKCFLIS)
+32 QUIT
+33 ;
+34 ;============================
+35 ;GETFLIST(index#,.fieldList)
+36 ;============================
+37 ;Loop through Cross Reference Values multiple and
+38 ;build list of fields used in Index XR. (Existing items in fieldList
+39 ;array are NOT deleted.)
+40 ;In:
+41 ; XR = Index ien
+42 ;Out:
+43 ; FLIST(file#,field#) = ""
+44 ;
GETFLIST(XR,FLIST) ;
+1 NEW FIL,FLD,I
+2 SET I=0
FOR
SET I=$ORDER(^DD("IX",XR,11.1,I))
if 'I
QUIT
Begin DoDot:1
+3 if $PIECE($GET(^DD("IX",XR,11.1,I,0)),U,2)'="F"
QUIT
+4 SET FIL=$PIECE(^DD("IX",XR,11.1,I,0),U,3)
SET FLD=$PIECE(^(0),U,4)
if 'FIL
QUIT
if 'FLD
QUIT
+5 SET FLIST(FIL,FLD)=""
End DoDot:1
+6 QUIT
