Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIKCR

DIKCR.m

Go to the documentation of this file. 
  1. DIKCR ;SFISC/MKO-API TO CREATE A NEW-STYLE XREF ;9:55 AM  1 Nov 2002 [ 12/09/2003  4:44 PM ]
  1.  ;;22.0;VA FileMan;**95,1002**;Mar 30, 1999
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. CREIXN(DIKCXREF,DIFLG,DIXR,DIKCOUT,DIKCMSG) ;Create a new-style index
  1.  ;DIFLG:
  1.  ; e : Throw away Dialog errors
  1.  ; r : Don't recompile templates, xrefs
  1.  ; W : Write messages to the current device
  1.  ; S : Execute set logic of new xref
  1.  ;
  1. CREIXNX ;Entry point from DDMOD
  1.  N DIKCDEL,DIKCXR,DIKCDMSG,DIKCERR,X,Y
  1.  ;
  1.  ;Init
  1.  S DIFLG=$G(DIFLG)
  1.  I DIFLG["e" S DIKCMSG="DIKCDMSG" N DIERR
  1.  I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
  1.  S DIKCDEL=$G(DIKCXREF("NAME"))]""
  1.  M DIKCXR=DIKCXREF
  1.  ;
  1.  ;Check input, set defaults
  1.  D CHK(.DIKCXR,.DIKCERR) G:DIKCERR EXIT
  1.  D CHKVAL(.DIKCXR,.DIKCERR) G:DIKCERR EXIT
  1.  ;
  1.  ;Delete the old index of the same name
  1.  D:DIKCDEL
  1.  . N DIKCFLAG,DIERR,DIKCDMSG
  1.  . S DIKCFLAG="d"_$E("W",DIFLG["W")_$E("K",DIFLG'["k")
  1.  . D DELIXN^DDMOD(DIKCXR("FILE"),DIKCXR("NAME"),DIKCFLAG,"","DIKCDMSG")
  1.  ;
  1.  ;Create the index
  1.  D UPDATE(.DIKCXR,.DIXR,DIFLG) I DIXR="" S DIKCERR=1 G EXIT
  1.  ;
  1.  ;Execute set logic
  1.  D:DIFLG["S" SET(DIXR,DIFLG)
  1.  ;
  1.  ;Recompile templates and xrefs
  1.  D:DIFLG'["r" RECOMP(DIXR,DIFLG)
  1.  ;
  1. EXIT ;Write and move error messages if necessary
  1.  I $G(DIERR) D
  1.  . D:DIFLG["W" MSG^DIALOG("WES")
  1.  . D:$G(DIKCMSG)]"" CALLOUT^DIEFU(DIKCMSG)
  1.  I $G(DIKCERR) S DIXR=""
  1.  E  S DIXR=DIXR_U_DIKCXR("NAME")
  1.  Q
  1.  ;
  1. UPDATE(DIKCXR,DIXR,DIFLG) ;Call Updater to create index, return DIXR=ien
  1.  N DIKCFDA,DIKCIEN,IENS,ORD,R,SEQ,X
  1.  W:$G(DIFLG)["W" !,"Creating index definition ..."
  1.  ;
  1.  ;Set FDA for top level Index file fields
  1.  S DIKCFDA(.11,"+1,",.01)=DIKCXR("FILE")
  1.  S DIKCFDA(.11,"+1,",.02)=DIKCXR("NAME")
  1.  S DIKCFDA(.11,"+1,",.11)=DIKCXR("SHORT DESCR")
  1.  S DIKCFDA(.11,"+1,",.2)=DIKCXR("TYPE")
  1.  S DIKCFDA(.11,"+1,",.4)=DIKCXR("EXECUTION")
  1.  S DIKCFDA(.11,"+1,",.41)=DIKCXR("ACTIVITY")
  1.  S DIKCFDA(.11,"+1,",.42)=DIKCXR("USE")
  1.  S DIKCFDA(.11,"+1,",.5)=DIKCXR("ROOT TYPE")
  1.  S DIKCFDA(.11,"+1,",.51)=DIKCXR("ROOT FILE")
  1.  S DIKCFDA(.11,"+1,",1.1)=$S($G(DIKCXR("SET"))]"":DIKCXR("SET"),1:"Q")
  1.  S DIKCFDA(.11,"+1,",2.1)=$S($G(DIKCXR("KILL"))]"":DIKCXR("KILL"),1:"Q")
  1.  S:$G(DIKCXR("SET CONDITION"))]"" DIKCFDA(.11,"+1,",1.4)=DIKCXR("SET CONDITION")
  1.  S:$G(DIKCXR("KILL CONDITION"))]"" DIKCFDA(.11,"+1,",2.4)=DIKCXR("KILL CONDITION")
  1.  S:$G(DIKCXR("WHOLE KILL"))]"" DIKCFDA(.11,"+1,",2.5)=DIKCXR("WHOLE KILL")
  1.  ;
  1.  ;Set FDA for Values multiple
  1.  S ORD=0 F SEQ=2:1 S ORD=$O(DIKCXR("VAL",ORD)) Q:'ORD  D
  1.  . S IENS="+"_SEQ_",+1,"
  1.  . S R=$NA(DIKCXR("VAL",ORD))
  1.  . S DIKCFDA(.114,IENS,.01)=ORD
  1.  . S DIKCFDA(.114,IENS,1)=@R@("TYPE")
  1.  . ;
  1.  . I @R@("TYPE")="C" S DIKCFDA(.114,IENS,4.5)=@R
  1.  . E  D
  1.  .. S DIKCFDA(.114,IENS,2)=DIKCXR("ROOT FILE")
  1.  .. S DIKCFDA(.114,IENS,3)=@R
  1.  .. S X=$G(@R@("XFORM FOR STORAGE")) S:X]"" DIKCFDA(.114,IENS,5)=X
  1.  .. S X=$G(@R@("XFORM FOR LOOKUP")) S:X]"" DIKCFDA(.114,IENS,5.3)=X
  1.  .. S X=$G(@R@("XFORM FOR DISPLAY")) S:X]"" DIKCFDA(.114,IENS,5.5)=X
  1.  . ;
  1.  . S X=$G(@R@("SUBSCRIPT")) S:X]"" DIKCFDA(.114,IENS,.5)=X
  1.  . S X=$G(@R@("LENGTH")) S:X]"" DIKCFDA(.114,IENS,6)=X
  1.  . S X=$G(@R@("COLLATION")) S:X]"" DIKCFDA(.114,IENS,7)=X
  1.  . S X=$G(@R@("LOOKUP PROMPT")) S:X]"" DIKCFDA(.114,IENS,8)=X
  1.  ;
  1.  ;Call Updater
  1.  D UPDATE^DIE("E","DIKCFDA","DIKCIEN")
  1.  K DIXR I $G(DIERR) S DIXR="" Q
  1.  S DIXR=DIKCIEN(1)
  1.  ;
  1.  ;Add Description
  1.  D:$O(DIKCXR("DESCR",0)) WP^DIE(.11,DIXR_",",.1,"",$NA(DIKCXR("DESCR")))
  1.  Q
  1.  ;
  1. RECOMP(DIXR,DIFLG) ;Recompile templates and xrefs, update triggering fields
  1.  N DIKCFLIS,DIKCI,DIKCTLIS,DIKCTOP,DIKTEML
  1.  ;
  1.  ;Get top level file number
  1.  S DIKCTOP=$$FNO^DILIBF($P($G(^DD("IX",DIXR,0)),U)) Q:'DIKCTOP
  1.  ;
  1.  ;Get list of fields in xref
  1.  D GETFLIST^DIKCUTL(DIXR,.DIKCFLIS) Q:'$D(DIKCFLIS)
  1.  ;
  1.  ;Recompile input templates and xrefs
  1.  D DIEZ^DIKD2(.DIKCFLIS,DIFLG,$G(DIKCOUT))
  1.  D DIKZ^DIKD(DIKCTOP,DIFLG,$G(DIKCOUT)) S DIKCTOP(DIKCTOP)=""
  1.  ;
  1.  ;Also update triggering fields, and their compiled templates and xrefs
  1.  D TRIG^DICR(.DIKCFLIS,.DIKCTLIS)
  1.  I $D(DIKCTLIS) D
  1.  . D DIEZ^DIKD2(.DIKCTLIS,DIFLG,$G(DIKCOUT))
  1.  . S DIKCI=0 F  S DIKCI=$O(DIKCTLIS(DIKCI)) Q:'DIKCI  D
  1.  .. S DIKCTOP=+$$FNO^DILIBF(DIKCI) Q:$D(DIKCTOP(DIKCTOP))#2!'DIKCTOP
  1.  .. S DIKCTOP(DIKCTOP)=""
  1.  .. D DIKZ^DIKD(DIKCTOP,DIFLG,$G(DIKCOUT))
  1.  Q
  1.  ;
  1. CHK(DIKCXR,DIKCERR) ;Check/default input array
  1.  N FIL,NAM,RFIL,TYP,USE
  1.  S DIKCERR=0
  1.  ;
  1.  ;Check FILE
  1.  S FIL=$G(DIKCXR("FILE")) I 'FIL D ER202("FILE") Q
  1.  I '$$VFNUM^DIKCU1(FIL,"D") S DIKCERR=1 Q
  1.  ;
  1.  ;Check Type, get internal form
  1.  S TYP=$G(DIKCXR("TYPE")) I TYP="" D ER202("TYPE") Q
  1.  D CHK^DIE(.11,.2,"",TYP,.TYP) I TYP=U S DIKCERR=1 Q
  1.  S DIKCXR("TYPE")=TYP
  1.  ;
  1.  ;Check USE, get internal form.
  1.  S USE=$G(DIKCXR("USE"))
  1.  I USE]"" D CHK^DIE(.11,.42,"",USE,.USE) I USE=U S DIKCERR=1 Q
  1.  S DIKCXR("USE")=USE
  1.  ;
  1.  S NAM=$G(DIKCXR("NAME"))
  1.  S RFIL=$G(DIKCXR("ROOT FILE"))
  1.  ;
  1.  ;Check Root File, set Root Type
  1.  S:'RFIL (RFIL,DIKCXR("ROOT FILE"))=FIL
  1.  I FIL=RFIL S DIKCXR("ROOT TYPE")="I"
  1.  E  D  Q:DIKCERR
  1.  . I $$FLEVDIFF^DIKCU(FIL,RFIL)="" D ER202("ROOT FILE") Q
  1.  . I '$$VFNUM^DIKCU1(RFIL,"D") S DIKCERR=1 Q
  1.  . S DIKCXR("ROOT TYPE")="W"
  1.  ;
  1.  ;Check USE, NAME, TYPE
  1.  I NAM="",USE="" D ER202("NAME/USE") Q
  1.  I $E(NAM)="A",USE="LS" D ER202("NAME/USE") Q
  1.  I USE="A",TYP'="MU" D ER202("TYPE/USE") Q
  1.  ;
  1.  ;Default NAM based on USE and FILE
  1.  ; or USE based on NAME and TYPE
  1.  I NAM="" S DIKCXR("NAME")=$$GETNAM(FIL,USE)
  1.  E  I USE="" S DIKCXR("USE")=$S($E(NAM)="A":$S(TYP="MU":"A",1:"S"),1:"LS")
  1.  ;
  1.  ;Check SHORT DESCRIPTION'=null', if null set default Activity
  1.  I $G(DIKCXR("SHORT DESCR"))="" D ER202("SHORT DESCR") Q
  1.  S:$D(DIKCXR("ACTIVITY"))[0 DIKCXR("ACTIVITY")="IR"
  1.  Q
  1.  ;
  1. CHKVAL(DIKCXR,DIKCERR) ;Check values, build logic for regular indexes
  1.  N CNT,FCNT,FIL,KILL,L,LEV,LDIF,MAXL,NAM,ORD,RFIL,ROOT,SBSC,SEQ,SET,TYP,VAL,WKIL
  1.  ;
  1.  S FIL=DIKCXR("FILE")
  1.  S NAM=DIKCXR("NAME")
  1.  S RFIL=DIKCXR("ROOT FILE")
  1.  S TYP=DIKCXR("TYPE")
  1.  S DIKCERR=0
  1.  ;
  1.  ;Begin building logic for regular indexes
  1.  I TYP="R" D  Q:DIKCERR
  1.  . I FIL'=RFIL S LDIF=$$FLEVDIFF^DIKCU(FIL,RFIL)
  1.  . E  S LDIF=0
  1.  . S ROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O",.LEV)_""""_NAM_""""
  1.  . I $D(DIERR) S DIKCERR=1 Q
  1.  . S WKIL="K "_ROOT_")"
  1.  ;
  1.  ;Build list of subscripts, count #values and #fields
  1.  S ORD=0 F  S ORD=$O(DIKCXR("VAL",ORD)) Q:'ORD  D  Q:DIKCERR
  1.  . I $G(DIKCXR("VAL",ORD))="" K DIKCXR("VAL",ORD) Q
  1.  . S CNT=$G(CNT)+1
  1.  . ;
  1.  . ;Get type of value; if field, increment field count
  1.  . I DIKCXR("VAL",ORD) S DIKCXR("VAL",ORD,"TYPE")="F",FCNT=$G(FCNT)+1
  1.  . E  S DIKCXR("VAL",ORD,"TYPE")="C"
  1.  . ;
  1.  . ;Set subscript array; error if duplicate subscript #
  1.  . S SBSC=$G(DIKCXR("VAL",ORD,"SUBSCRIPT")) Q:'SBSC
  1.  . I $D(SBSC(SBSC))#2 D ER202("SUBSCRIPT") Q
  1.  . S SBSC(SBSC)=ORD_U_$G(DIKCXR("VAL",ORD,"LENGTH"))
  1.  . ;
  1.  . ;Set default collation
  1.  . S:$G(DIKCXR("VAL",ORD,"COLLATION"))="" DIKCXR("VAL",ORD,"COLLATION")="F"
  1.  Q:DIKCERR
  1.  ;
  1.  S SBSC=0 F SEQ=1:1 S SBSC=$O(SBSC(SBSC)) Q:'SBSC  D  Q:DIKCERR
  1.  . ;Check that subscripts are consecutive from 1
  1.  . I SEQ'=SBSC D ER202("SUBSCRIPTS") Q
  1.  . Q:TYP="MU"
  1.  . ;
  1.  . ;Continue building logic for regular indexes
  1.  . S ORD=$P(SBSC(SBSC),U),MAXL=$P(SBSC(SBSC),U,2)
  1.  . I $G(CNT)=1 S VAL=$S(MAXL:"$E(X,1,"_MAXL_")",1:"X")
  1.  . E  S VAL=$S(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")")
  1.  . S ROOT=ROOT_","_VAL
  1.  ;
  1.  ;If null, default Execution based on #fields
  1.  S:$G(DIKCXR("EXECUTION"))="" DIKCXR("EXECUTION")=$S($G(FCNT)>1:"R",1:"F")
  1.  ;
  1.  ;We're done for MUMPS xrefs
  1.  Q:TYP="MU"
  1.  ;
  1.  ;Continue building logic for regular indexes
  1.  F L=LDIF:-1:1 S ROOT=ROOT_",DA("_L_")"
  1.  S ROOT=ROOT_",DA)"
  1.  ;
  1.  I '$O(SBSC(0)) S (SET,KILL)="Q",WKIL=""
  1.  E  S SET="S "_ROOT_"=""""",KILL="K "_ROOT
  1.  S DIKCXR("SET")=SET
  1.  S DIKCXR("KILL")=KILL
  1.  S DIKCXR("WHOLE KILL")=WKIL
  1.  Q
  1.  ;
  1. GETNAM(F01,USE) ;Get next available index name
  1.  N ASC,STRT,NAME,I
  1.  S STRT=$S(USE="LS":"",1:"A")
  1.  F ASC=67:1:89 D  Q:NAME]""
  1.  . S NAME=STRT_$C(ASC)
  1.  . I $D(^DD("IX","BB",F01,NAME)) S NAME="" Q
  1.  . I $D(^DD(F01,0,"IX",NAME)) S NAME="" Q
  1.  Q:NAME]"" NAME
  1.  ;
  1.  F I=1:1 D  Q:NAME]""
  1.  . S NAME=STRT_"C"_I
  1.  . I $D(^DD("IX","BB",F01,NAME)) S NAME="" Q
  1.  . I $D(^DD(F01,0,"IX",NAME)) S NAME="" Q
  1.  Q NAME
  1.  ;
  1. SET(DIXR,DIFLG) ;Execute set logic
  1.  N DIKCRFIL,DIKCTOP,DIKCTRL,DIKCTYP
  1.  ;
  1.  S DIKCTOP=$$FNO^DILIBF($P($G(^DD("IX",DIXR,0)),U)) Q:'DIKCTOP
  1.  S DIKCRFIL=$P($G(^DD("IX",DIXR,0)),U,9) Q:'DIKCRFIL
  1.  S DIKCTYP=$P($G(^DD("IX",DIXR,0)),U,4)
  1.  ;
  1.  I $G(DIFLG)["W" D
  1.  . I DIKCTYP="R" W !,"Building index ..."
  1.  . E  W !,"Executing set logic ..."
  1.  ;
  1.  ;Call INDEX^DIKC to execute the set logic
  1.  S DIKCTRL="S"_$S(DIKCTOP'=DIKCRFIL:"W"_DIKCRFIL,1:"")
  1.  D INDEX^DIKC(DIKCTOP,"","",DIXR,.DIKCTRL)
  1.  Q
  1.  ;
  1. ER202(DIKCP1) ;;The input variable or parameter that identifies the |1| is missing or invalid.
  1.  D ERR^DIKCU2(202,"","","",DIKCP1)
  1.  S DIKCERR=1
  1.  Q