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

DIKC.m

Go to the documentation of this file. 
  1. DIKC ;SFISC/MKO-FIRE INDEX FILE CROSS REFERENCES ;24OCT2012
  1.  ;;22.0;VA FileMan;**1,22,11,68,95,146,167**;Mar 30, 1999;Build 20
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1. INDEX(DIFILE,DIREC,DIFLD,DIXREF,DICTRL) ;Fire Index file xrefs
  1.  N DA,DIF,DIKACT,DIKCT,DIKERR,DIKLOCK,DIKLOG,DIKON,DIKRFIL
  1.  N DIKTMP,DIKVAL,DIMF,DIROOT
  1.  ;
  1.  ;Initialization
  1.  S DIF=$E("D",$G(DICTRL)["D")
  1.  I DIF["D",'$D(DIQUIET) N DIQUIET S DIQUIET=1
  1.  I DIF["D",'$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
  1.  ;
  1.  ;Check (and convert) input parameters
  1.  D CHK^DIKC2 G:$G(DIKERR)]"" EXIT
  1.  ;
  1.  ;Setup variables
  1.  S DIKCT=$E("C",$G(DICTRL)["C")_$E("T",$G(DICTRL)["T")
  1.  S DIKLOG=$E("K",$G(DICTRL)["K")_$E("S",$G(DICTRL)["S")
  1.  S:DIKLOG="" DIKLOG=$E("K",DIKCT'["C")_$E("S",DIKCT'["T")
  1.  S DIKACT=$E("R",$G(DICTRL)["R")_$E("I",$G(DICTRL)["I")
  1.  S DIKRFIL=$S($G(DICTRL)["W":+$P(DICTRL,"W",2),1:DIFILE)
  1.  I $G(DICTRL)["k" D
  1.  . S DIKLOCK=+$P(DICTRL,"k",2)\1
  1.  . S:DIKLOCK<0 DIKLOCK=-DIKLOCK
  1.  . S:$E($P(DICTRL,"k",2))="-" DIKLOCK("STOP")=1
  1.  E  S DIKLOCK=1
  1.  ;
  1. LOAD ;Load xref information into @DIKTMP
  1.  S DIKTMP=$G(DICTRL("LOGIC"))
  1.  I $G(DIKTMP)="" D
  1.  . S DIKTMP=$$GETTMP^DIKC1("DIKC")
  1.  . I $G(DIXREF)?."^" D
  1.  .. I $G(DIFLD) D
  1.  ...D LOADFLD^DIKC1(DIKRFIL,DIFLD,DIKLOG_"W",DIKACT,DIKVAL,DIKTMP,DIKTMP,$E("i",$G(DICTRL)["i"),,$E("x",$G(DICTRL)["x"))
  1.  .. E  D LOADALL^DIKC1(DIKRFIL,DIKLOG,DIKACT,DIKVAL,DIKTMP,$E("s",$G(DICTRL)["s")_$E("i",$G(DICTRL)["i")_$E("x",$G(DICTRL)["x"),.DIMF)
  1.  . E  D LOADXREF^DIKC1(DIKRFIL,$G(DIFLD),DIKLOG,.DIXREF,DIKVAL,DIKTMP)
  1.  ;
  1.  D:DIKRFIL'=DIFILE SBINFO^DIKCU(DIKRFIL,.DIMF)
  1.  ;
  1.  ;Fire the xrefs for all records or the record specified in DA
  1.  I 'DA D
  1.  . L +@DIROOT:DIKLOCK E  D  Q:$G(DIKLOCK("STOP"))
  1.  .. S DIKLOCK=""
  1.  .. D:DIF["D" ERR^DIKCU2(112,DIFILE)
  1.  . D FIREALL(DIFILE,.DA,DIROOT,DIKLOG,.DIMF,DIKTMP,DIKON,"",DIKCT)
  1.  . L:DIKLOCK]"" -@DIROOT
  1.  E  D
  1.  . L +@DIROOT@(DA):DIKLOCK E  D  Q:$G(DIKLOCK("STOP"))
  1.  .. S DIKLOCK=""
  1.  .. D:DIF["D" ERR^DIKCU2(110,DIFILE,$$IENS^DIKCU(DIFILE,.DA))
  1.  . D:$D(@DIKTMP@(DIFILE)) FIRE(DIFILE,.DA,DIKLOG,DIKTMP,DIKON,"",DIKCT)
  1.  . D:$D(DIMF(DIFILE)) FIRESUB(DIFILE,.DA,DIROOT,DIKLOG,.DIMF,DIKTMP,DIKON,"",DIKCT)
  1.  . L:DIKLOCK]"" -@DIROOT@(DA)
  1.  ;
  1.  ;Cleanup ^TMP
  1.  K @DIKTMP
  1.  ;
  1. EXIT ;Move error messages if necessary
  1.  I DIF["D",$G(DIERR),$G(DICTRL("MSG"))]"" D CALLOUT^DIEFU(DICTRL("MSG"))
  1.  Q
  1.  ;
  1. FIREALL(DIFILE,DA,DIROOT,DILOG,DIMF,DIKTMP,DIKON,DIKEY,DIKCT) ;Fire xrefs, all recs
  1.  N DICNT,DIIENS,DILAST,DIXR
  1.  S DILOG=$G(DILOG),DIKON=$G(DIKON)
  1.  S DIIENS=$$IENS^DIKCU(DIFILE,.DA)
  1.  ;
  1.  ;Kill entire indexes
  1.  I DILOG["K",$D(@DIKTMP@("KW",DIFILE)) D XECKW(DIFILE,.DA,$D(DIMF(DIFILE))>0)
  1.  I '$D(@DIKTMP@(DIFILE)),'$D(DIMF(DIFILE)) Q
  1.  ;
  1.  ;Loop through all records in the file
  1.  S (DICNT,DA)=0 F  S DA=$O(@DIROOT@(DA)) Q:DA'=+DA  D
  1.  . S $P(DIIENS,",")=DA
  1.  . S DICNT=DICNT+1
  1.  . D:$D(@DIKTMP@(DIFILE)) FIRE(DIFILE,.DA,DILOG,DIKTMP,DIKON,.DIKEY,DIKCT,DIIENS)
  1.  . D:$D(DIMF(DIFILE)) FIRESUB(DIFILE,.DA,DIROOT,DILOG,.DIMF,DIKTMP,DIKON,.DIKEY,DIKCT)
  1.  ;
  1.  ;Update header node
  1.  I $D(@DIROOT@(0))#2 D
  1.  . S DILAST=$O(@DIROOT@(" "),-1) S:'DILAST DILAST=""
  1.  . S:'DICNT DICNT=""
  1.  . S $P(@DIROOT@(0),U,4)=DICNT ;**DI*22*146
  1.  Q
  1.  ;
  1. FIRE(DIFILE,DA,DILOG,DIKTMP,DIKON,DIKEY,DIKCT,DIIENS) ;Fire xrefs, one record
  1.  N DI01,DIKCLOG,DINULL,DION,DIXR,I,J,X,X2,XN
  1.  S DILOG=$G(DILOG),DIKON=$G(DIKON)
  1.  S:$G(DIIENS)="" DIIENS=$$IENS^DIKCU(DIFILE,.DA)
  1.  ;
  1.  I DIKON="" S DIXR=0 F  S DIXR=$O(@DIKTMP@(DIFILE,DIXR)) Q:DIXR'=+DIXR  D
  1.  . D SETXARR(DIFILE,DIXR,DIKTMP,.DINULL) Q:DINULL
  1.  . I $G(DIKCT)="" D XECUTE(DIFILE,DIXR,DILOG,.X,.X,DIKTMP) Q
  1.  . ;
  1.  . K XN S XN="",I=0 F  S I=$O(X(I)) Q:'I  S XN(I)=""
  1.  . I $G(DIKCT)="C" D XECUTE(DIFILE,DIXR,"S",.XN,.X,DIKTMP) Q
  1.  . I $G(DIKCT)="T" D XECUTE(DIFILE,DIXR,"K",.X,.XN,DIKTMP) Q
  1.  ;
  1.  E  S DIXR=0 F  S DIXR=$O(@DIKTMP@(DIFILE,DIXR)) Q:DIXR'=+DIXR  D
  1.  . K DINFLD
  1.  . S DIKCLOG=""
  1.  . ;
  1.  . ;Set X2 array to new values
  1.  . S DION=$P(DIKON,U,2)
  1.  . D SETXARR(DIFILE,DIXR,DIKTMP,.DINULL,DION) M X2=X
  1.  . ;
  1.  . ;If SET requested, make sure no new values are null
  1.  . I DILOG["S" D
  1.  .. I 'DINULL S DIKCLOG="S"
  1.  .. E  I $P(DIKON,U,4)="N" S I=0 F  S I=$O(^DD("KEY","AU",DIXR,I)) Q:'I  D
  1.  ... S DIKEY(DIFILE,I,DIIENS)="n"
  1.  ... S J=0 F  S J=$O(DINULL(J)) Q:'J  S DIKEY(DIFILE,I,DIIENS,$P(DINULL(J),U),$P(DINULL(J),U,2))=$P(DINULL(J),U,3)
  1.  . ;
  1.  . ;Set X array to old values
  1.  . S DION=$P(DIKON,U)
  1.  . D SETXARR(DIFILE,DIXR,DIKTMP,.DINULL,DION,.DI01)
  1.  . ;
  1.  . ;If KILL requested, make sure no old values are null
  1.  . I DILOG["K",'DINULL S DIKCLOG="K"_DIKCLOG
  1.  . ;
  1.  . ;If "C" flag, set old .01 value to null
  1.  . I $G(DIKCT)="C",$D(DI01) D
  1.  .. S I=0 F  S I=$O(DI01(I)) Q:'I  S X(I)=""
  1.  .. S:$O(DI01(0))=$O(X(0)) X=""
  1.  .. S DIKCLOG=$TR(DIKCLOG,"K")
  1.  . ;
  1.  . ;If "T" flag, set all new values to null
  1.  . I $G(DIKCT)="T" S X2="",I=0 F  S I=$O(X2(I)) Q:'I  S X2(I)=""
  1.  . ;
  1.  . ;Execute the kill and set logic
  1.  . D XECUTE(DIFILE,DIXR,DIKCLOG,.X,.X2,DIKTMP)
  1.  . ;
  1.  . I DIKCLOG["S",$P(DIKON,U,3)="K",$D(^DD("KEY","AU",DIXR)) D
  1.  .. Q:$$UNIQUE^DIKK2(DIFILE,DIXR,.X2,.DA,DIKTMP)
  1.  .. S I=0 F  S I=$O(^DD("KEY","AU",DIXR,I)) Q:'I  S DIKEY(DIFILE,I,DIIENS)=""
  1.  Q
  1.  ;
  1. FIRESUB(DIFILE,DA,DIROOT,DILOG,DIMF,DIKTMP,DIKON,DIKEY,DIKCT) ;Fire xrefs for
  1.  ;all subfiles under DIFILE, for all subrecords under DA
  1.  Q:'$D(DIMF(DIFILE))
  1.  N DIMULTF,DISBFILE,DISBROOT,X
  1.  S DILOG=$G(DILOG),DIKON=$G(DIKON)
  1.  ;
  1.  ;Push down the DA array
  1.  D PUSHDA^DIKCU(.DA)
  1.  ;
  1.  ;Loop through DIMF array and fire xrefs for subfiles
  1.  S DIMULTF=0 F  S DIMULTF=$O(DIMF(DIFILE,DIMULTF)) Q:'DIMULTF  D
  1.  . S DISBROOT=$NA(@DIROOT@(DA(1),DIMF(DIFILE,DIMULTF))) Q:'$D(@DISBROOT)
  1.  . S DISBFILE=DIMF(DIFILE,DIMULTF,0)
  1.  . D FIREALL(DISBFILE,.DA,DISBROOT,DILOG,.DIMF,DIKTMP,DIKON,.DIKEY,DIKCT)
  1.  ;
  1.  ;Pop the DA array
  1.  D POPDA^DIKCU(.DA)
  1.  Q
  1.  ;
  1. XECUTE(DIFILE,DIXR,DILOG,DIKCX1,DIKCX2,DIKTMP) ;Xecute the logic in ^TMP
  1.  Q:$G(DILOG)=""
  1.  N DIKCOD,DIKCON,X,X1,X2
  1.  ;
  1.  ;Execute kill logic
  1.  I DILOG["K" D
  1.  . S DIKCOD=$G(@DIKTMP@(DIFILE,DIXR,"K")) Q:DIKCOD?."^"
  1.  . S DIKCON=$G(@DIKTMP@(DIFILE,DIXR,"KC"))
  1.  . I DIKCON'?."^" M X=DIKCX1,X1=DIKCX1,X2=DIKCX2 X DIKCON Q:'$G(X)  K X,X1,X2
  1.  . M X=DIKCX1,X1=DIKCX1,X2=DIKCX2
  1.  . X DIKCOD K X,X1,X2
  1.  ;
  1.  ;Execute set logic
  1.  I DILOG["S" D
  1.  . S DIKCOD=$G(@DIKTMP@(DIFILE,DIXR,"S")) Q:DIKCOD?."^"
  1.  . S DIKCON=$G(@DIKTMP@(DIFILE,DIXR,"SC"))
  1.  . I DIKCON'?."^" M X=DIKCX2,X1=DIKCX1,X2=DIKCX2 X DIKCON Q:'$G(X)  K X,X1,X2
  1.  . M X=DIKCX2,X1=DIKCX1,X2=DIKCX2
  1.  . X DIKCOD
  1.  Q
  1.  ;
  1. XECKW(DIFILE,DA,DIKSUB) ;Execute the logic to kill the entire index
  1.  N DIKFIL,DIKKW,DIKKW0,DIKLDIF,DIXR
  1.  ;
  1.  S DIXR=0 F  S DIXR=$O(@DIKTMP@("KW",DIFILE,DIXR)) Q:DIXR'=+DIXR  D
  1.  . S DIKKW=$G(@DIKTMP@("KW",DIFILE,DIXR)) Q:DIKKW?."^"
  1.  . S DIKKW0=$G(@DIKTMP@("KW",DIFILE,DIXR,0))
  1.  . ;
  1.  . ;If not a whole file xref, kill the entire index and quit
  1.  . I DIKKW0="" X DIKKW D  Q
  1.  .. I '$D(@DIKTMP@(DIFILE,DIXR,"S")) K @DIKTMP@(DIFILE,DIXR)
  1.  .. E  K @DIKTMP@(DIFILE,DIXR,"K"),@DIKTMP@(DIFILE,DIXR,"KC")
  1.  . ;
  1.  . ;Quit if this isn't a whole file xref or we're not doing subfiles
  1.  . Q:$P(DIKKW0,U)'="W"!'$G(DIKSUB)
  1.  . ;
  1.  . ;Kill the whole index after pushing DA the appropriate amount
  1.  . S DIKFIL=$P(DIKKW0,U,2),DIKLDIF=$P(DIKKW0,U,3)
  1.  . D PUSHDA^DIKCU(.DA,DIKLDIF)
  1.  . X DIKKW
  1.  . I '$D(@DIKTMP@(DIKFIL,DIXR,"S")) K @DIKTMP@(DIKFIL,DIXR)
  1.  . E  K @DIKTMP@(DIKFIL,DIXR,"K"),@DIKTMP@(DIKFIL,DIXR,"KC")
  1.  . D POPDA^DIKCU(.DA,DIKLDIF)
  1.  Q
  1.  ;
  1. SETXARR(DIFILE,DIXR,DIKTMP,DINULL,DION,DI01) ;Loop through DIKTMP and set X array.
  1.  ;If any values used as subscripts are null, return
  1.  ; DINULL=1
  1.  ; DINULL(order#) = ""
  1.  ;                  or file^field^levDiff (for field type subscripts)
  1.  ; DI01(order#) = "" if order # is .01 field
  1.  ;
  1.  N DIKCX,DIKF,DIKO,X1,X2
  1.  K X,DI01,DINULL
  1.  S DINULL=0,(DIKF,DIKO)=$O(@DIKTMP@(DIFILE,DIXR,0)) Q:'DIKF
  1.  ;
  1.  S:$G(DION)="" DION=U
  1.  F  D  S DIKO=$O(@DIKTMP@(DIFILE,DIXR,DIKO)) Q:'DIKO
  1.  . K DIKCX M DIKCX=X
  1.  . X $G(@DIKTMP@(DIFILE,DIXR,DIKO))
  1.  . I $G(X)]"",$D(@DIKTMP@(DIFILE,DIXR,DIKO,"T")) X @DIKTMP@(DIFILE,DIXR,DIKO,"T")
  1.  . S:$D(X)#2 (DIKCX,DIKCX(DIKO))=X K X M X=DIKCX
  1.  . S:$P($G(@DIKTMP@(DIFILE,DIXR,DIKO,"F")),U,2)=.01 DI01(DIKO)=""
  1.  . I $G(X(DIKO))="",$G(@DIKTMP@(DIFILE,DIXR,DIKO,"SS")) S DINULL=1 S:$G(@DIKTMP@(DIFILE,DIXR,DIKO,"F")) DINULL(DIKO)=@DIKTMP@(DIFILE,DIXR,DIKO,"F")
  1.  ;
  1.  S:$D(X(DIKF))#2 X=$G(X(DIKF))
  1.  Q
  1.  ;
  1.  ;#110  The record is currently locked.
  1.  ;#112  The file is currently locked.