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