DIKCR ;SFISC/MKO-API TO CREATE A NEW-STYLE XREF ;9:55 AM  1 Nov 2002
 ;;22.0;VA FileMan;**95**;Mar 30, 1999
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
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