DIKCR ;SFISC/MKO-API TO CREATE A NEW-STYLE XREF ;9:55 AM 1 Nov 2002
;;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.
;
CREIXN(DIKCXREF,DIFLG,DIXR,DIKCOUT,DIKCMSG) ;Create a new-style index
;DIFLG:
; e : Throw away Dialog errors
; r : Don't recompile templates, xrefs
; W : Write messages to the current device
; S : Execute set logic of new xref
;
CREIXNX ;Entry point from DDMOD
N DIKCDEL,DIKCXR,DIKCDMSG,DIKCERR,X,Y
;
;Init
S DIFLG=$G(DIFLG)
I DIFLG["e" S DIKCMSG="DIKCDMSG" N DIERR
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
S DIKCDEL=$G(DIKCXREF("NAME"))]""
M DIKCXR=DIKCXREF
;
;Check input, set defaults
D CHK(.DIKCXR,.DIKCERR) G:DIKCERR EXIT
D CHKVAL(.DIKCXR,.DIKCERR) G:DIKCERR EXIT
;
;Delete the old index of the same name
D:DIKCDEL
. N DIKCFLAG,DIERR,DIKCDMSG
. S DIKCFLAG="d"_$E("W",DIFLG["W")_$E("K",DIFLG'["k")
. D DELIXN^DDMOD(DIKCXR("FILE"),DIKCXR("NAME"),DIKCFLAG,"","DIKCDMSG")
;
;Create the index
D UPDATE(.DIKCXR,.DIXR,DIFLG) I DIXR="" S DIKCERR=1 G EXIT
;
;Execute set logic
D:DIFLG["S" SET(DIXR,DIFLG)
;
;Recompile templates and xrefs
D:DIFLG'["r" RECOMP(DIXR,DIFLG)
;
EXIT ;Write and move error messages if necessary
I $G(DIERR) D
. D:DIFLG["W" MSG^DIALOG("WES")
. D:$G(DIKCMSG)]"" CALLOUT^DIEFU(DIKCMSG)
I $G(DIKCERR) S DIXR=""
E S DIXR=DIXR_U_DIKCXR("NAME")
Q
;
UPDATE(DIKCXR,DIXR,DIFLG) ;Call Updater to create index, return DIXR=ien
N DIKCFDA,DIKCIEN,IENS,ORD,R,SEQ,X
W:$G(DIFLG)["W" !,"Creating index definition ..."
;
;Set FDA for top level Index file fields
S DIKCFDA(.11,"+1,",.01)=DIKCXR("FILE")
S DIKCFDA(.11,"+1,",.02)=DIKCXR("NAME")
S DIKCFDA(.11,"+1,",.11)=DIKCXR("SHORT DESCR")
S DIKCFDA(.11,"+1,",.2)=DIKCXR("TYPE")
S DIKCFDA(.11,"+1,",.4)=DIKCXR("EXECUTION")
S DIKCFDA(.11,"+1,",.41)=DIKCXR("ACTIVITY")
S DIKCFDA(.11,"+1,",.42)=DIKCXR("USE")
S DIKCFDA(.11,"+1,",.5)=DIKCXR("ROOT TYPE")
S DIKCFDA(.11,"+1,",.51)=DIKCXR("ROOT FILE")
S DIKCFDA(.11,"+1,",1.1)=$S($G(DIKCXR("SET"))]"":DIKCXR("SET"),1:"Q")
S DIKCFDA(.11,"+1,",2.1)=$S($G(DIKCXR("KILL"))]"":DIKCXR("KILL"),1:"Q")
S:$G(DIKCXR("SET CONDITION"))]"" DIKCFDA(.11,"+1,",1.4)=DIKCXR("SET CONDITION")
S:$G(DIKCXR("KILL CONDITION"))]"" DIKCFDA(.11,"+1,",2.4)=DIKCXR("KILL CONDITION")
S:$G(DIKCXR("WHOLE KILL"))]"" DIKCFDA(.11,"+1,",2.5)=DIKCXR("WHOLE KILL")
;
;Set FDA for Values multiple
S ORD=0 F SEQ=2:1 S ORD=$O(DIKCXR("VAL",ORD)) Q:'ORD D
. S IENS="+"_SEQ_",+1,"
. S R=$NA(DIKCXR("VAL",ORD))
. S DIKCFDA(.114,IENS,.01)=ORD
. S DIKCFDA(.114,IENS,1)=@R@("TYPE")
. ;
. I @R@("TYPE")="C" S DIKCFDA(.114,IENS,4.5)=@R
. E D
.. S DIKCFDA(.114,IENS,2)=DIKCXR("ROOT FILE")
.. S DIKCFDA(.114,IENS,3)=@R
.. S X=$G(@R@("XFORM FOR STORAGE")) S:X]"" DIKCFDA(.114,IENS,5)=X
.. S X=$G(@R@("XFORM FOR LOOKUP")) S:X]"" DIKCFDA(.114,IENS,5.3)=X
.. S X=$G(@R@("XFORM FOR DISPLAY")) S:X]"" DIKCFDA(.114,IENS,5.5)=X
. ;
. S X=$G(@R@("SUBSCRIPT")) S:X]"" DIKCFDA(.114,IENS,.5)=X
. S X=$G(@R@("LENGTH")) S:X]"" DIKCFDA(.114,IENS,6)=X
. S X=$G(@R@("COLLATION")) S:X]"" DIKCFDA(.114,IENS,7)=X
. S X=$G(@R@("LOOKUP PROMPT")) S:X]"" DIKCFDA(.114,IENS,8)=X
;
;Call Updater
D UPDATE^DIE("E","DIKCFDA","DIKCIEN")
K DIXR I $G(DIERR) S DIXR="" Q
S DIXR=DIKCIEN(1)
;
;Add Description
D:$O(DIKCXR("DESCR",0)) WP^DIE(.11,DIXR_",",.1,"",$NA(DIKCXR("DESCR")))
Q
;
RECOMP(DIXR,DIFLG) ;Recompile templates and xrefs, update triggering fields
N DIKCFLIS,DIKCI,DIKCTLIS,DIKCTOP,DIKTEML
;
;Get top level file number
S DIKCTOP=$$FNO^DILIBF($P($G(^DD("IX",DIXR,0)),U)) Q:'DIKCTOP
;
;Get list of fields in xref
D GETFLIST^DIKCUTL(DIXR,.DIKCFLIS) Q:'$D(DIKCFLIS)
;
;Recompile input templates and xrefs
D DIEZ^DIKD2(.DIKCFLIS,DIFLG,$G(DIKCOUT))
D DIKZ^DIKD(DIKCTOP,DIFLG,$G(DIKCOUT)) S DIKCTOP(DIKCTOP)=""
;
;Also update triggering fields, and their compiled templates and xrefs
D TRIG^DICR(.DIKCFLIS,.DIKCTLIS)
I $D(DIKCTLIS) D
. D DIEZ^DIKD2(.DIKCTLIS,DIFLG,$G(DIKCOUT))
. S DIKCI=0 F S DIKCI=$O(DIKCTLIS(DIKCI)) Q:'DIKCI D
.. S DIKCTOP=+$$FNO^DILIBF(DIKCI) Q:$D(DIKCTOP(DIKCTOP))#2!'DIKCTOP
.. S DIKCTOP(DIKCTOP)=""
.. D DIKZ^DIKD(DIKCTOP,DIFLG,$G(DIKCOUT))
Q
;
CHK(DIKCXR,DIKCERR) ;Check/default input array
N FIL,NAM,RFIL,TYP,USE
S DIKCERR=0
;
;Check FILE
S FIL=$G(DIKCXR("FILE")) I 'FIL D ER202("FILE") Q
I '$$VFNUM^DIKCU1(FIL,"D") S DIKCERR=1 Q
;
;Check Type, get internal form
S TYP=$G(DIKCXR("TYPE")) I TYP="" D ER202("TYPE") Q
D CHK^DIE(.11,.2,"",TYP,.TYP) I TYP=U S DIKCERR=1 Q
S DIKCXR("TYPE")=TYP
;
;Check USE, get internal form.
S USE=$G(DIKCXR("USE"))
I USE]"" D CHK^DIE(.11,.42,"",USE,.USE) I USE=U S DIKCERR=1 Q
S DIKCXR("USE")=USE
;
S NAM=$G(DIKCXR("NAME"))
S RFIL=$G(DIKCXR("ROOT FILE"))
;
;Check Root File, set Root Type
S:'RFIL (RFIL,DIKCXR("ROOT FILE"))=FIL
I FIL=RFIL S DIKCXR("ROOT TYPE")="I"
E D Q:DIKCERR
. I $$FLEVDIFF^DIKCU(FIL,RFIL)="" D ER202("ROOT FILE") Q
. I '$$VFNUM^DIKCU1(RFIL,"D") S DIKCERR=1 Q
. S DIKCXR("ROOT TYPE")="W"
;
;Check USE, NAME, TYPE
I NAM="",USE="" D ER202("NAME/USE") Q
I $E(NAM)="A",USE="LS" D ER202("NAME/USE") Q
I USE="A",TYP'="MU" D ER202("TYPE/USE") Q
;
;Default NAM based on USE and FILE
; or USE based on NAME and TYPE
I NAM="" S DIKCXR("NAME")=$$GETNAM(FIL,USE)
E I USE="" S DIKCXR("USE")=$S($E(NAM)="A":$S(TYP="MU":"A",1:"S"),1:"LS")
;
;Check SHORT DESCRIPTION'=null', if null set default Activity
I $G(DIKCXR("SHORT DESCR"))="" D ER202("SHORT DESCR") Q
S:$D(DIKCXR("ACTIVITY"))[0 DIKCXR("ACTIVITY")="IR"
Q
;
CHKVAL(DIKCXR,DIKCERR) ;Check values, build logic for regular indexes
N CNT,FCNT,FIL,KILL,L,LEV,LDIF,MAXL,NAM,ORD,RFIL,ROOT,SBSC,SEQ,SET,TYP,VAL,WKIL
;
S FIL=DIKCXR("FILE")
S NAM=DIKCXR("NAME")
S RFIL=DIKCXR("ROOT FILE")
S TYP=DIKCXR("TYPE")
S DIKCERR=0
;
;Begin building logic for regular indexes
I TYP="R" D Q:DIKCERR
. I FIL'=RFIL S LDIF=$$FLEVDIFF^DIKCU(FIL,RFIL)
. E S LDIF=0
. S ROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O",.LEV)_""""_NAM_""""
. I $D(DIERR) S DIKCERR=1 Q
. S WKIL="K "_ROOT_")"
;
;Build list of subscripts, count #values and #fields
S ORD=0 F S ORD=$O(DIKCXR("VAL",ORD)) Q:'ORD D Q:DIKCERR
. I $G(DIKCXR("VAL",ORD))="" K DIKCXR("VAL",ORD) Q
. S CNT=$G(CNT)+1
. ;
. ;Get type of value; if field, increment field count
. I DIKCXR("VAL",ORD) S DIKCXR("VAL",ORD,"TYPE")="F",FCNT=$G(FCNT)+1
. E S DIKCXR("VAL",ORD,"TYPE")="C"
. ;
. ;Set subscript array; error if duplicate subscript #
. S SBSC=$G(DIKCXR("VAL",ORD,"SUBSCRIPT")) Q:'SBSC
. I $D(SBSC(SBSC))#2 D ER202("SUBSCRIPT") Q
. S SBSC(SBSC)=ORD_U_$G(DIKCXR("VAL",ORD,"LENGTH"))
. ;
. ;Set default collation
. S:$G(DIKCXR("VAL",ORD,"COLLATION"))="" DIKCXR("VAL",ORD,"COLLATION")="F"
Q:DIKCERR
;
S SBSC=0 F SEQ=1:1 S SBSC=$O(SBSC(SBSC)) Q:'SBSC D Q:DIKCERR
. ;Check that subscripts are consecutive from 1
. I SEQ'=SBSC D ER202("SUBSCRIPTS") Q
. Q:TYP="MU"
. ;
. ;Continue building logic for regular indexes
. S ORD=$P(SBSC(SBSC),U),MAXL=$P(SBSC(SBSC),U,2)
. I $G(CNT)=1 S VAL=$S(MAXL:"$E(X,1,"_MAXL_")",1:"X")
. E S VAL=$S(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")")
. S ROOT=ROOT_","_VAL
;
;If null, default Execution based on #fields
S:$G(DIKCXR("EXECUTION"))="" DIKCXR("EXECUTION")=$S($G(FCNT)>1:"R",1:"F")
;
;We're done for MUMPS xrefs
Q:TYP="MU"
;
;Continue building logic for regular indexes
F L=LDIF:-1:1 S ROOT=ROOT_",DA("_L_")"
S ROOT=ROOT_",DA)"
;
I '$O(SBSC(0)) S (SET,KILL)="Q",WKIL=""
E S SET="S "_ROOT_"=""""",KILL="K "_ROOT
S DIKCXR("SET")=SET
S DIKCXR("KILL")=KILL
S DIKCXR("WHOLE KILL")=WKIL
Q
;
GETNAM(F01,USE) ;Get next available index name
N ASC,STRT,NAME,I
S STRT=$S(USE="LS":"",1:"A")
F ASC=67:1:89 D Q:NAME]""
. S NAME=STRT_$C(ASC)
. I $D(^DD("IX","BB",F01,NAME)) S NAME="" Q
. I $D(^DD(F01,0,"IX",NAME)) S NAME="" Q
Q:NAME]"" NAME
;
F I=1:1 D Q:NAME]""
. S NAME=STRT_"C"_I
. I $D(^DD("IX","BB",F01,NAME)) S NAME="" Q
. I $D(^DD(F01,0,"IX",NAME)) S NAME="" Q
Q NAME
;
SET(DIXR,DIFLG) ;Execute set logic
N DIKCRFIL,DIKCTOP,DIKCTRL,DIKCTYP
;
S DIKCTOP=$$FNO^DILIBF($P($G(^DD("IX",DIXR,0)),U)) Q:'DIKCTOP
S DIKCRFIL=$P($G(^DD("IX",DIXR,0)),U,9) Q:'DIKCRFIL
S DIKCTYP=$P($G(^DD("IX",DIXR,0)),U,4)
;
I $G(DIFLG)["W" D
. I DIKCTYP="R" W !,"Building index ..."
. E W !,"Executing set logic ..."
;
;Call INDEX^DIKC to execute the set logic
S DIKCTRL="S"_$S(DIKCTOP'=DIKCRFIL:"W"_DIKCRFIL,1:"")
D INDEX^DIKC(DIKCTOP,"","",DIXR,.DIKCTRL)
Q
;
ER202(DIKCP1) ;;The input variable or parameter that identifies the |1| is missing or invalid.
D ERR^DIKCU2(202,"","","",DIKCP1)
S DIKCERR=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKCR 9065 printed Sep 23, 2025@20:24:55 Page 2
DIKCR ;SFISC/MKO-API TO CREATE A NEW-STYLE XREF ;9:55 AM 1 Nov 2002
+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 ;
CREIXN(DIKCXREF,DIFLG,DIXR,DIKCOUT,DIKCMSG) ;Create a new-style index
+1 ;DIFLG:
+2 ; e : Throw away Dialog errors
+3 ; r : Don't recompile templates, xrefs
+4 ; W : Write messages to the current device
+5 ; S : Execute set logic of new xref
+6 ;
CREIXNX ;Entry point from DDMOD
+1 NEW DIKCDEL,DIKCXR,DIKCDMSG,DIKCERR,X,Y
+2 ;
+3 ;Init
+4 SET DIFLG=$GET(DIFLG)
+5 IF DIFLG["e"
SET DIKCMSG="DIKCDMSG"
NEW DIERR
+6 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+7 SET DIKCDEL=$GET(DIKCXREF("NAME"))]""
+8 MERGE DIKCXR=DIKCXREF
+9 ;
+10 ;Check input, set defaults
+11 DO CHK(.DIKCXR,.DIKCERR)
if DIKCERR
GOTO EXIT
+12 DO CHKVAL(.DIKCXR,.DIKCERR)
if DIKCERR
GOTO EXIT
+13 ;
+14 ;Delete the old index of the same name
+15 if DIKCDEL
Begin DoDot:1
+16 NEW DIKCFLAG,DIERR,DIKCDMSG
+17 SET DIKCFLAG="d"_$EXTRACT("W",DIFLG["W")_$EXTRACT("K",DIFLG'["k")
+18 DO DELIXN^DDMOD(DIKCXR("FILE"),DIKCXR("NAME"),DIKCFLAG,"","DIKCDMSG")
End DoDot:1
+19 ;
+20 ;Create the index
+21 DO UPDATE(.DIKCXR,.DIXR,DIFLG)
IF DIXR=""
SET DIKCERR=1
GOTO EXIT
+22 ;
+23 ;Execute set logic
+24 if DIFLG["S"
DO SET(DIXR,DIFLG)
+25 ;
+26 ;Recompile templates and xrefs
+27 if DIFLG'["r"
DO RECOMP(DIXR,DIFLG)
+28 ;
EXIT ;Write and move error messages if necessary
+1 IF $GET(DIERR)
Begin DoDot:1
+2 if DIFLG["W"
DO MSG^DIALOG("WES")
+3 if $GET(DIKCMSG)]""
DO CALLOUT^DIEFU(DIKCMSG)
End DoDot:1
+4 IF $GET(DIKCERR)
SET DIXR=""
+5 IF '$TEST
SET DIXR=DIXR_U_DIKCXR("NAME")
+6 QUIT
+7 ;
UPDATE(DIKCXR,DIXR,DIFLG) ;Call Updater to create index, return DIXR=ien
+1 NEW DIKCFDA,DIKCIEN,IENS,ORD,R,SEQ,X
+2 if $GET(DIFLG)["W"
WRITE !,"Creating index definition ..."
+3 ;
+4 ;Set FDA for top level Index file fields
+5 SET DIKCFDA(.11,"+1,",.01)=DIKCXR("FILE")
+6 SET DIKCFDA(.11,"+1,",.02)=DIKCXR("NAME")
+7 SET DIKCFDA(.11,"+1,",.11)=DIKCXR("SHORT DESCR")
+8 SET DIKCFDA(.11,"+1,",.2)=DIKCXR("TYPE")
+9 SET DIKCFDA(.11,"+1,",.4)=DIKCXR("EXECUTION")
+10 SET DIKCFDA(.11,"+1,",.41)=DIKCXR("ACTIVITY")
+11 SET DIKCFDA(.11,"+1,",.42)=DIKCXR("USE")
+12 SET DIKCFDA(.11,"+1,",.5)=DIKCXR("ROOT TYPE")
+13 SET DIKCFDA(.11,"+1,",.51)=DIKCXR("ROOT FILE")
+14 SET DIKCFDA(.11,"+1,",1.1)=$SELECT($GET(DIKCXR("SET"))]"":DIKCXR("SET"),1:"Q")
+15 SET DIKCFDA(.11,"+1,",2.1)=$SELECT($GET(DIKCXR("KILL"))]"":DIKCXR("KILL"),1:"Q")
+16 if $GET(DIKCXR("SET CONDITION"))]""
SET DIKCFDA(.11,"+1,",1.4)=DIKCXR("SET CONDITION")
+17 if $GET(DIKCXR("KILL CONDITION"))]""
SET DIKCFDA(.11,"+1,",2.4)=DIKCXR("KILL CONDITION")
+18 if $GET(DIKCXR("WHOLE KILL"))]""
SET DIKCFDA(.11,"+1,",2.5)=DIKCXR("WHOLE KILL")
+19 ;
+20 ;Set FDA for Values multiple
+21 SET ORD=0
FOR SEQ=2:1
SET ORD=$ORDER(DIKCXR("VAL",ORD))
if 'ORD
QUIT
Begin DoDot:1
+22 SET IENS="+"_SEQ_",+1,"
+23 SET R=$NAME(DIKCXR("VAL",ORD))
+24 SET DIKCFDA(.114,IENS,.01)=ORD
+25 SET DIKCFDA(.114,IENS,1)=@R@("TYPE")
+26 ;
+27 IF @R@("TYPE")="C"
SET DIKCFDA(.114,IENS,4.5)=@R
+28 IF '$TEST
Begin DoDot:2
+29 SET DIKCFDA(.114,IENS,2)=DIKCXR("ROOT FILE")
+30 SET DIKCFDA(.114,IENS,3)=@R
+31 SET X=$GET(@R@("XFORM FOR STORAGE"))
if X]""
SET DIKCFDA(.114,IENS,5)=X
+32 SET X=$GET(@R@("XFORM FOR LOOKUP"))
if X]""
SET DIKCFDA(.114,IENS,5.3)=X
+33 SET X=$GET(@R@("XFORM FOR DISPLAY"))
if X]""
SET DIKCFDA(.114,IENS,5.5)=X
End DoDot:2
+34 ;
+35 SET X=$GET(@R@("SUBSCRIPT"))
if X]""
SET DIKCFDA(.114,IENS,.5)=X
+36 SET X=$GET(@R@("LENGTH"))
if X]""
SET DIKCFDA(.114,IENS,6)=X
+37 SET X=$GET(@R@("COLLATION"))
if X]""
SET DIKCFDA(.114,IENS,7)=X
+38 SET X=$GET(@R@("LOOKUP PROMPT"))
if X]""
SET DIKCFDA(.114,IENS,8)=X
End DoDot:1
+39 ;
+40 ;Call Updater
+41 DO UPDATE^DIE("E","DIKCFDA","DIKCIEN")
+42 KILL DIXR
IF $GET(DIERR)
SET DIXR=""
QUIT
+43 SET DIXR=DIKCIEN(1)
+44 ;
+45 ;Add Description
+46 if $ORDER(DIKCXR("DESCR",0))
DO WP^DIE(.11,DIXR_",",.1,"",$NAME(DIKCXR("DESCR")))
+47 QUIT
+48 ;
RECOMP(DIXR,DIFLG) ;Recompile templates and xrefs, update triggering fields
+1 NEW DIKCFLIS,DIKCI,DIKCTLIS,DIKCTOP,DIKTEML
+2 ;
+3 ;Get top level file number
+4 SET DIKCTOP=$$FNO^DILIBF($PIECE($GET(^DD("IX",DIXR,0)),U))
if 'DIKCTOP
QUIT
+5 ;
+6 ;Get list of fields in xref
+7 DO GETFLIST^DIKCUTL(DIXR,.DIKCFLIS)
if '$DATA(DIKCFLIS)
QUIT
+8 ;
+9 ;Recompile input templates and xrefs
+10 DO DIEZ^DIKD2(.DIKCFLIS,DIFLG,$GET(DIKCOUT))
+11 DO DIKZ^DIKD(DIKCTOP,DIFLG,$GET(DIKCOUT))
SET DIKCTOP(DIKCTOP)=""
+12 ;
+13 ;Also update triggering fields, and their compiled templates and xrefs
+14 DO TRIG^DICR(.DIKCFLIS,.DIKCTLIS)
+15 IF $DATA(DIKCTLIS)
Begin DoDot:1
+16 DO DIEZ^DIKD2(.DIKCTLIS,DIFLG,$GET(DIKCOUT))
+17 SET DIKCI=0
FOR
SET DIKCI=$ORDER(DIKCTLIS(DIKCI))
if 'DIKCI
QUIT
Begin DoDot:2
+18 SET DIKCTOP=+$$FNO^DILIBF(DIKCI)
if $DATA(DIKCTOP(DIKCTOP))#2!'DIKCTOP
QUIT
+19 SET DIKCTOP(DIKCTOP)=""
+20 DO DIKZ^DIKD(DIKCTOP,DIFLG,$GET(DIKCOUT))
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
CHK(DIKCXR,DIKCERR) ;Check/default input array
+1 NEW FIL,NAM,RFIL,TYP,USE
+2 SET DIKCERR=0
+3 ;
+4 ;Check FILE
+5 SET FIL=$GET(DIKCXR("FILE"))
IF 'FIL
DO ER202("FILE")
QUIT
+6 IF '$$VFNUM^DIKCU1(FIL,"D")
SET DIKCERR=1
QUIT
+7 ;
+8 ;Check Type, get internal form
+9 SET TYP=$GET(DIKCXR("TYPE"))
IF TYP=""
DO ER202("TYPE")
QUIT
+10 DO CHK^DIE(.11,.2,"",TYP,.TYP)
IF TYP=U
SET DIKCERR=1
QUIT
+11 SET DIKCXR("TYPE")=TYP
+12 ;
+13 ;Check USE, get internal form.
+14 SET USE=$GET(DIKCXR("USE"))
+15 IF USE]""
DO CHK^DIE(.11,.42,"",USE,.USE)
IF USE=U
SET DIKCERR=1
QUIT
+16 SET DIKCXR("USE")=USE
+17 ;
+18 SET NAM=$GET(DIKCXR("NAME"))
+19 SET RFIL=$GET(DIKCXR("ROOT FILE"))
+20 ;
+21 ;Check Root File, set Root Type
+22 if 'RFIL
SET (RFIL,DIKCXR("ROOT FILE"))=FIL
+23 IF FIL=RFIL
SET DIKCXR("ROOT TYPE")="I"
+24 IF '$TEST
Begin DoDot:1
+25 IF $$FLEVDIFF^DIKCU(FIL,RFIL)=""
DO ER202("ROOT FILE")
QUIT
+26 IF '$$VFNUM^DIKCU1(RFIL,"D")
SET DIKCERR=1
QUIT
+27 SET DIKCXR("ROOT TYPE")="W"
End DoDot:1
if DIKCERR
QUIT
+28 ;
+29 ;Check USE, NAME, TYPE
+30 IF NAM=""
IF USE=""
DO ER202("NAME/USE")
QUIT
+31 IF $EXTRACT(NAM)="A"
IF USE="LS"
DO ER202("NAME/USE")
QUIT
+32 IF USE="A"
IF TYP'="MU"
DO ER202("TYPE/USE")
QUIT
+33 ;
+34 ;Default NAM based on USE and FILE
+35 ; or USE based on NAME and TYPE
+36 IF NAM=""
SET DIKCXR("NAME")=$$GETNAM(FIL,USE)
+37 IF '$TEST
IF USE=""
SET DIKCXR("USE")=$SELECT($EXTRACT(NAM)="A":$SELECT(TYP="MU":"A",1:"S"),1:"LS")
+38 ;
+39 ;Check SHORT DESCRIPTION'=null', if null set default Activity
+40 IF $GET(DIKCXR("SHORT DESCR"))=""
DO ER202("SHORT DESCR")
QUIT
+41 if $DATA(DIKCXR("ACTIVITY"))[0
SET DIKCXR("ACTIVITY")="IR"
+42 QUIT
+43 ;
CHKVAL(DIKCXR,DIKCERR) ;Check values, build logic for regular indexes
+1 NEW CNT,FCNT,FIL,KILL,L,LEV,LDIF,MAXL,NAM,ORD,RFIL,ROOT,SBSC,SEQ,SET,TYP,VAL,WKIL
+2 ;
+3 SET FIL=DIKCXR("FILE")
+4 SET NAM=DIKCXR("NAME")
+5 SET RFIL=DIKCXR("ROOT FILE")
+6 SET TYP=DIKCXR("TYPE")
+7 SET DIKCERR=0
+8 ;
+9 ;Begin building logic for regular indexes
+10 IF TYP="R"
Begin DoDot:1
+11 IF FIL'=RFIL
SET LDIF=$$FLEVDIFF^DIKCU(FIL,RFIL)
+12 IF '$TEST
SET LDIF=0
+13 SET ROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O",.LEV)_""""_NAM_""""
+14 IF $DATA(DIERR)
SET DIKCERR=1
QUIT
+15 SET WKIL="K "_ROOT_")"
End DoDot:1
if DIKCERR
QUIT
+16 ;
+17 ;Build list of subscripts, count #values and #fields
+18 SET ORD=0
FOR
SET ORD=$ORDER(DIKCXR("VAL",ORD))
if 'ORD
QUIT
Begin DoDot:1
+19 IF $GET(DIKCXR("VAL",ORD))=""
KILL DIKCXR("VAL",ORD)
QUIT
+20 SET CNT=$GET(CNT)+1
+21 ;
+22 ;Get type of value; if field, increment field count
+23 IF DIKCXR("VAL",ORD)
SET DIKCXR("VAL",ORD,"TYPE")="F"
SET FCNT=$GET(FCNT)+1
+24 IF '$TEST
SET DIKCXR("VAL",ORD,"TYPE")="C"
+25 ;
+26 ;Set subscript array; error if duplicate subscript #
+27 SET SBSC=$GET(DIKCXR("VAL",ORD,"SUBSCRIPT"))
if 'SBSC
QUIT
+28 IF $DATA(SBSC(SBSC))#2
DO ER202("SUBSCRIPT")
QUIT
+29 SET SBSC(SBSC)=ORD_U_$GET(DIKCXR("VAL",ORD,"LENGTH"))
+30 ;
+31 ;Set default collation
+32 if $GET(DIKCXR("VAL",ORD,"COLLATION"))=""
SET DIKCXR("VAL",ORD,"COLLATION")="F"
End DoDot:1
if DIKCERR
QUIT
+33 if DIKCERR
QUIT
+34 ;
+35 SET SBSC=0
FOR SEQ=1:1
SET SBSC=$ORDER(SBSC(SBSC))
if 'SBSC
QUIT
Begin DoDot:1
+36 ;Check that subscripts are consecutive from 1
+37 IF SEQ'=SBSC
DO ER202("SUBSCRIPTS")
QUIT
+38 if TYP="MU"
QUIT
+39 ;
+40 ;Continue building logic for regular indexes
+41 SET ORD=$PIECE(SBSC(SBSC),U)
SET MAXL=$PIECE(SBSC(SBSC),U,2)
+42 IF $GET(CNT)=1
SET VAL=$SELECT(MAXL:"$E(X,1,"_MAXL_")",1:"X")
+43 IF '$TEST
SET VAL=$SELECT(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")")
+44 SET ROOT=ROOT_","_VAL
End DoDot:1
if DIKCERR
QUIT
+45 ;
+46 ;If null, default Execution based on #fields
+47 if $GET(DIKCXR("EXECUTION"))=""
SET DIKCXR("EXECUTION")=$SELECT($GET(FCNT)>1:"R",1:"F")
+48 ;
+49 ;We're done for MUMPS xrefs
+50 if TYP="MU"
QUIT
+51 ;
+52 ;Continue building logic for regular indexes
+53 FOR L=LDIF:-1:1
SET ROOT=ROOT_",DA("_L_")"
+54 SET ROOT=ROOT_",DA)"
+55 ;
+56 IF '$ORDER(SBSC(0))
SET (SET,KILL)="Q"
SET WKIL=""
+57 IF '$TEST
SET SET="S "_ROOT_"="""""
SET KILL="K "_ROOT
+58 SET DIKCXR("SET")=SET
+59 SET DIKCXR("KILL")=KILL
+60 SET DIKCXR("WHOLE KILL")=WKIL
+61 QUIT
+62 ;
GETNAM(F01,USE) ;Get next available index name
+1 NEW ASC,STRT,NAME,I
+2 SET STRT=$SELECT(USE="LS":"",1:"A")
+3 FOR ASC=67:1:89
Begin DoDot:1
+4 SET NAME=STRT_$CHAR(ASC)
+5 IF $DATA(^DD("IX","BB",F01,NAME))
SET NAME=""
QUIT
+6 IF $DATA(^DD(F01,0,"IX",NAME))
SET NAME=""
QUIT
End DoDot:1
if NAME]""
QUIT
+7 if NAME]""
QUIT NAME
+8 ;
+9 FOR I=1:1
Begin DoDot:1
+10 SET NAME=STRT_"C"_I
+11 IF $DATA(^DD("IX","BB",F01,NAME))
SET NAME=""
QUIT
+12 IF $DATA(^DD(F01,0,"IX",NAME))
SET NAME=""
QUIT
End DoDot:1
if NAME]""
QUIT
+13 QUIT NAME
+14 ;
SET(DIXR,DIFLG) ;Execute set logic
+1 NEW DIKCRFIL,DIKCTOP,DIKCTRL,DIKCTYP
+2 ;
+3 SET DIKCTOP=$$FNO^DILIBF($PIECE($GET(^DD("IX",DIXR,0)),U))
if 'DIKCTOP
QUIT
+4 SET DIKCRFIL=$PIECE($GET(^DD("IX",DIXR,0)),U,9)
if 'DIKCRFIL
QUIT
+5 SET DIKCTYP=$PIECE($GET(^DD("IX",DIXR,0)),U,4)
+6 ;
+7 IF $GET(DIFLG)["W"
Begin DoDot:1
+8 IF DIKCTYP="R"
WRITE !,"Building index ..."
+9 IF '$TEST
WRITE !,"Executing set logic ..."
End DoDot:1
+10 ;
+11 ;Call INDEX^DIKC to execute the set logic
+12 SET DIKCTRL="S"_$SELECT(DIKCTOP'=DIKCRFIL:"W"_DIKCRFIL,1:"")
+13 DO INDEX^DIKC(DIKCTOP,"","",DIXR,.DIKCTRL)
+14 QUIT
+15 ;
ER202(DIKCP1) ;;The input variable or parameter that identifies the |1| is missing or invalid.
+1 DO ERR^DIKCU2(202,"","","",DIKCP1)
+2 SET DIKCERR=1
+3 QUIT
