DIKC ;SFISC/MKO-FIRE INDEX FILE CROSS REFERENCES ;24OCT2012
;;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.
;
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 ;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("x",$G(DICTRL)["x"))
.. 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)
. 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.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKC 8622 printed Oct 16, 2024@18:49:13 Page 2
DIKC ;SFISC/MKO-FIRE INDEX FILE CROSS REFERENCES ;24OCT2012
+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 ;
INDEX(DIFILE,DIREC,DIFLD,DIXREF,DICTRL) ;Fire Index file xrefs
+1 NEW DA,DIF,DIKACT,DIKCT,DIKERR,DIKLOCK,DIKLOG,DIKON,DIKRFIL
+2 NEW DIKTMP,DIKVAL,DIMF,DIROOT
+3 ;
+4 ;Initialization
+5 SET DIF=$EXTRACT("D",$GET(DICTRL)["D")
+6 IF DIF["D"
IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+7 IF DIF["D"
IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+8 ;
+9 ;Check (and convert) input parameters
+10 DO CHK^DIKC2
if $GET(DIKERR)]""
GOTO EXIT
+11 ;
+12 ;Setup variables
+13 SET DIKCT=$EXTRACT("C",$GET(DICTRL)["C")_$EXTRACT("T",$GET(DICTRL)["T")
+14 SET DIKLOG=$EXTRACT("K",$GET(DICTRL)["K")_$EXTRACT("S",$GET(DICTRL)["S")
+15 if DIKLOG=""
SET DIKLOG=$EXTRACT("K",DIKCT'["C")_$EXTRACT("S",DIKCT'["T")
+16 SET DIKACT=$EXTRACT("R",$GET(DICTRL)["R")_$EXTRACT("I",$GET(DICTRL)["I")
+17 SET DIKRFIL=$SELECT($GET(DICTRL)["W":+$PIECE(DICTRL,"W",2),1:DIFILE)
+18 IF $GET(DICTRL)["k"
Begin DoDot:1
+19 SET DIKLOCK=+$PIECE(DICTRL,"k",2)\1
+20 if DIKLOCK<0
SET DIKLOCK=-DIKLOCK
+21 if $EXTRACT($PIECE(DICTRL,"k",2))="-"
SET DIKLOCK("STOP")=1
End DoDot:1
+22 IF '$TEST
SET DIKLOCK=1
+23 ;
LOAD ;Load xref information into @DIKTMP
+1 SET DIKTMP=$GET(DICTRL("LOGIC"))
+2 IF $GET(DIKTMP)=""
Begin DoDot:1
+3 SET DIKTMP=$$GETTMP^DIKC1("DIKC")
+4 IF $GET(DIXREF)?."^"
Begin DoDot:2
+5 IF $GET(DIFLD)
Begin DoDot:3
+6 DO LOADFLD^DIKC1(DIKRFIL,DIFLD,DIKLOG_"W",DIKACT,DIKVAL,DIKTMP,DIKTMP,$EXTRACT("i",$GET(DICTRL)["i"),,$EXTRACT("x",$GET(DICTRL)["x"))
End DoDot:3
+7 IF '$TEST
DO LOADALL^DIKC1(DIKRFIL,DIKLOG,DIKACT,DIKVAL,DIKTMP,$EXTRACT("s",$GET(DICTRL)["s")_$EXTRACT("i",$GET(DICTRL)["i")_$EXTRACT("x",$GET(DICTRL)["x"),.DIMF)
End DoDot:2
+8 IF '$TEST
DO LOADXREF^DIKC1(DIKRFIL,$GET(DIFLD),DIKLOG,.DIXREF,DIKVAL,DIKTMP)
End DoDot:1
+9 ;
+10 if DIKRFIL'=DIFILE
DO SBINFO^DIKCU(DIKRFIL,.DIMF)
+11 ;
+12 ;Fire the xrefs for all records or the record specified in DA
+13 IF 'DA
Begin DoDot:1
+14 LOCK +@DIROOT:DIKLOCK
IF '$TEST
Begin DoDot:2
+15 SET DIKLOCK=""
+16 if DIF["D"
DO ERR^DIKCU2(112,DIFILE)
End DoDot:2
if $GET(DIKLOCK("STOP"))
QUIT
+17 DO FIREALL(DIFILE,.DA,DIROOT,DIKLOG,.DIMF,DIKTMP,DIKON,"",DIKCT)
+18 if DIKLOCK]""
LOCK -@DIROOT
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 LOCK +@DIROOT@(DA):DIKLOCK
IF '$TEST
Begin DoDot:2
+21 SET DIKLOCK=""
+22 if DIF["D"
DO ERR^DIKCU2(110,DIFILE,$$IENS^DIKCU(DIFILE,.DA))
End DoDot:2
if $GET(DIKLOCK("STOP"))
QUIT
+23 if $DATA(@DIKTMP@(DIFILE))
DO FIRE(DIFILE,.DA,DIKLOG,DIKTMP,DIKON,"",DIKCT)
+24 if $DATA(DIMF(DIFILE))
DO FIRESUB(DIFILE,.DA,DIROOT,DIKLOG,.DIMF,DIKTMP,DIKON,"",DIKCT)
+25 if DIKLOCK]""
LOCK -@DIROOT@(DA)
End DoDot:1
+26 ;
+27 ;Cleanup ^TMP
+28 KILL @DIKTMP
+29 ;
EXIT ;Move error messages if necessary
+1 IF DIF["D"
IF $GET(DIERR)
IF $GET(DICTRL("MSG"))]""
DO CALLOUT^DIEFU(DICTRL("MSG"))
+2 QUIT
+3 ;
FIREALL(DIFILE,DA,DIROOT,DILOG,DIMF,DIKTMP,DIKON,DIKEY,DIKCT) ;Fire xrefs, all recs
+1 NEW DICNT,DIIENS,DILAST,DIXR
+2 SET DILOG=$GET(DILOG)
SET DIKON=$GET(DIKON)
+3 SET DIIENS=$$IENS^DIKCU(DIFILE,.DA)
+4 ;
+5 ;Kill entire indexes
+6 IF DILOG["K"
IF $DATA(@DIKTMP@("KW",DIFILE))
DO XECKW(DIFILE,.DA,$DATA(DIMF(DIFILE))>0)
+7 IF '$DATA(@DIKTMP@(DIFILE))
IF '$DATA(DIMF(DIFILE))
QUIT
+8 ;
+9 ;Loop through all records in the file
+10 SET (DICNT,DA)=0
FOR
SET DA=$ORDER(@DIROOT@(DA))
if DA'=+DA
QUIT
Begin DoDot:1
+11 SET $PIECE(DIIENS,",")=DA
+12 SET DICNT=DICNT+1
+13 if $DATA(@DIKTMP@(DIFILE))
DO FIRE(DIFILE,.DA,DILOG,DIKTMP,DIKON,.DIKEY,DIKCT,DIIENS)
+14 if $DATA(DIMF(DIFILE))
DO FIRESUB(DIFILE,.DA,DIROOT,DILOG,.DIMF,DIKTMP,DIKON,.DIKEY,DIKCT)
End DoDot:1
+15 ;
+16 ;Update header node
+17 IF $DATA(@DIROOT@(0))#2
Begin DoDot:1
+18 SET DILAST=$ORDER(@DIROOT@(" "),-1)
if 'DILAST
SET DILAST=""
+19 if 'DICNT
SET DICNT=""
+20 ;**DI*22*146
SET $PIECE(@DIROOT@(0),U,4)=DICNT
End DoDot:1
+21 QUIT
+22 ;
FIRE(DIFILE,DA,DILOG,DIKTMP,DIKON,DIKEY,DIKCT,DIIENS) ;Fire xrefs, one record
+1 NEW DI01,DIKCLOG,DINULL,DION,DIXR,I,J,X,X2,XN
+2 SET DILOG=$GET(DILOG)
SET DIKON=$GET(DIKON)
+3 if $GET(DIIENS)=""
SET DIIENS=$$IENS^DIKCU(DIFILE,.DA)
+4 ;
+5 IF DIKON=""
SET DIXR=0
FOR
SET DIXR=$ORDER(@DIKTMP@(DIFILE,DIXR))
if DIXR'=+DIXR
QUIT
Begin DoDot:1
+6 DO SETXARR(DIFILE,DIXR,DIKTMP,.DINULL)
if DINULL
QUIT
+7 IF $GET(DIKCT)=""
DO XECUTE(DIFILE,DIXR,DILOG,.X,.X,DIKTMP)
QUIT
+8 ;
+9 KILL XN
SET XN=""
SET I=0
FOR
SET I=$ORDER(X(I))
if 'I
QUIT
SET XN(I)=""
+10 IF $GET(DIKCT)="C"
DO XECUTE(DIFILE,DIXR,"S",.XN,.X,DIKTMP)
QUIT
+11 IF $GET(DIKCT)="T"
DO XECUTE(DIFILE,DIXR,"K",.X,.XN,DIKTMP)
QUIT
End DoDot:1
+12 ;
+13 IF '$TEST
SET DIXR=0
FOR
SET DIXR=$ORDER(@DIKTMP@(DIFILE,DIXR))
if DIXR'=+DIXR
QUIT
Begin DoDot:1
+14 KILL DINFLD
+15 SET DIKCLOG=""
+16 ;
+17 ;Set X2 array to new values
+18 SET DION=$PIECE(DIKON,U,2)
+19 DO SETXARR(DIFILE,DIXR,DIKTMP,.DINULL,DION)
MERGE X2=X
+20 ;
+21 ;If SET requested, make sure no new values are null
+22 IF DILOG["S"
Begin DoDot:2
+23 IF 'DINULL
SET DIKCLOG="S"
+24 IF '$TEST
IF $PIECE(DIKON,U,4)="N"
SET I=0
FOR
SET I=$ORDER(^DD("KEY","AU",DIXR,I))
if 'I
QUIT
Begin DoDot:3
+25 SET DIKEY(DIFILE,I,DIIENS)="n"
+26 SET J=0
FOR
SET J=$ORDER(DINULL(J))
if 'J
QUIT
SET DIKEY(DIFILE,I,DIIENS,$PIECE(DINULL(J),U),$PIECE(DINULL(J),U,2))=$PIECE(DINULL(J),U,3)
End DoDot:3
End DoDot:2
+27 ;
+28 ;Set X array to old values
+29 SET DION=$PIECE(DIKON,U)
+30 DO SETXARR(DIFILE,DIXR,DIKTMP,.DINULL,DION,.DI01)
+31 ;
+32 ;If KILL requested, make sure no old values are null
+33 IF DILOG["K"
IF 'DINULL
SET DIKCLOG="K"_DIKCLOG
+34 ;
+35 ;If "C" flag, set old .01 value to null
+36 IF $GET(DIKCT)="C"
IF $DATA(DI01)
Begin DoDot:2
+37 SET I=0
FOR
SET I=$ORDER(DI01(I))
if 'I
QUIT
SET X(I)=""
+38 if $ORDER(DI01(0))=$ORDER(X(0))
SET X=""
+39 SET DIKCLOG=$TRANSLATE(DIKCLOG,"K")
End DoDot:2
+40 ;
+41 ;If "T" flag, set all new values to null
+42 IF $GET(DIKCT)="T"
SET X2=""
SET I=0
FOR
SET I=$ORDER(X2(I))
if 'I
QUIT
SET X2(I)=""
+43 ;
+44 ;Execute the kill and set logic
+45 DO XECUTE(DIFILE,DIXR,DIKCLOG,.X,.X2,DIKTMP)
+46 ;
+47 IF DIKCLOG["S"
IF $PIECE(DIKON,U,3)="K"
IF $DATA(^DD("KEY","AU",DIXR))
Begin DoDot:2
+48 if $$UNIQUE^DIKK2(DIFILE,DIXR,.X2,.DA,DIKTMP)
QUIT
+49 SET I=0
FOR
SET I=$ORDER(^DD("KEY","AU",DIXR,I))
if 'I
QUIT
SET DIKEY(DIFILE,I,DIIENS)=""
End DoDot:2
End DoDot:1
+50 QUIT
+51 ;
FIRESUB(DIFILE,DA,DIROOT,DILOG,DIMF,DIKTMP,DIKON,DIKEY,DIKCT) ;Fire xrefs for
+1 ;all subfiles under DIFILE, for all subrecords under DA
+2 if '$DATA(DIMF(DIFILE))
QUIT
+3 NEW DIMULTF,DISBFILE,DISBROOT,X
+4 SET DILOG=$GET(DILOG)
SET DIKON=$GET(DIKON)
+5 ;
+6 ;Push down the DA array
+7 DO PUSHDA^DIKCU(.DA)
+8 ;
+9 ;Loop through DIMF array and fire xrefs for subfiles
+10 SET DIMULTF=0
FOR
SET DIMULTF=$ORDER(DIMF(DIFILE,DIMULTF))
if 'DIMULTF
QUIT
Begin DoDot:1
+11 SET DISBROOT=$NAME(@DIROOT@(DA(1),DIMF(DIFILE,DIMULTF)))
if '$DATA(@DISBROOT)
QUIT
+12 SET DISBFILE=DIMF(DIFILE,DIMULTF,0)
+13 DO FIREALL(DISBFILE,.DA,DISBROOT,DILOG,.DIMF,DIKTMP,DIKON,.DIKEY,DIKCT)
End DoDot:1
+14 ;
+15 ;Pop the DA array
+16 DO POPDA^DIKCU(.DA)
+17 QUIT
+18 ;
XECUTE(DIFILE,DIXR,DILOG,DIKCX1,DIKCX2,DIKTMP) ;Xecute the logic in ^TMP
+1 if $GET(DILOG)=""
QUIT
+2 NEW DIKCOD,DIKCON,X,X1,X2
+3 ;
+4 ;Execute kill logic
+5 IF DILOG["K"
Begin DoDot:1
+6 SET DIKCOD=$GET(@DIKTMP@(DIFILE,DIXR,"K"))
if DIKCOD?."^"
QUIT
+7 SET DIKCON=$GET(@DIKTMP@(DIFILE,DIXR,"KC"))
+8 IF DIKCON'?."^"
MERGE X=DIKCX1,X1=DIKCX1,X2=DIKCX2
XECUTE DIKCON
if '$GET(X)
QUIT
KILL X,X1,X2
+9 MERGE X=DIKCX1,X1=DIKCX1,X2=DIKCX2
+10 XECUTE DIKCOD
KILL X,X1,X2
End DoDot:1
+11 ;
+12 ;Execute set logic
+13 IF DILOG["S"
Begin DoDot:1
+14 SET DIKCOD=$GET(@DIKTMP@(DIFILE,DIXR,"S"))
if DIKCOD?."^"
QUIT
+15 SET DIKCON=$GET(@DIKTMP@(DIFILE,DIXR,"SC"))
+16 IF DIKCON'?."^"
MERGE X=DIKCX2,X1=DIKCX1,X2=DIKCX2
XECUTE DIKCON
if '$GET(X)
QUIT
KILL X,X1,X2
+17 MERGE X=DIKCX2,X1=DIKCX1,X2=DIKCX2
+18 XECUTE DIKCOD
End DoDot:1
+19 QUIT
+20 ;
XECKW(DIFILE,DA,DIKSUB) ;Execute the logic to kill the entire index
+1 NEW DIKFIL,DIKKW,DIKKW0,DIKLDIF,DIXR
+2 ;
+3 SET DIXR=0
FOR
SET DIXR=$ORDER(@DIKTMP@("KW",DIFILE,DIXR))
if DIXR'=+DIXR
QUIT
Begin DoDot:1
+4 SET DIKKW=$GET(@DIKTMP@("KW",DIFILE,DIXR))
if DIKKW?."^"
QUIT
+5 SET DIKKW0=$GET(@DIKTMP@("KW",DIFILE,DIXR,0))
+6 ;
+7 ;If not a whole file xref, kill the entire index and quit
+8 IF DIKKW0=""
XECUTE DIKKW
Begin DoDot:2
+9 IF '$DATA(@DIKTMP@(DIFILE,DIXR,"S"))
KILL @DIKTMP@(DIFILE,DIXR)
+10 IF '$TEST
KILL @DIKTMP@(DIFILE,DIXR,"K"),@DIKTMP@(DIFILE,DIXR,"KC")
End DoDot:2
QUIT
+11 ;
+12 ;Quit if this isn't a whole file xref or we're not doing subfiles
+13 if $PIECE(DIKKW0,U)'="W"!'$GET(DIKSUB)
QUIT
+14 ;
+15 ;Kill the whole index after pushing DA the appropriate amount
+16 SET DIKFIL=$PIECE(DIKKW0,U,2)
SET DIKLDIF=$PIECE(DIKKW0,U,3)
+17 DO PUSHDA^DIKCU(.DA,DIKLDIF)
+18 XECUTE DIKKW
+19 IF '$DATA(@DIKTMP@(DIKFIL,DIXR,"S"))
KILL @DIKTMP@(DIKFIL,DIXR)
+20 IF '$TEST
KILL @DIKTMP@(DIKFIL,DIXR,"K"),@DIKTMP@(DIKFIL,DIXR,"KC")
+21 DO POPDA^DIKCU(.DA,DIKLDIF)
End DoDot:1
+22 QUIT
+23 ;
SETXARR(DIFILE,DIXR,DIKTMP,DINULL,DION,DI01) ;Loop through DIKTMP and set X array.
+1 ;If any values used as subscripts are null, return
+2 ; DINULL=1
+3 ; DINULL(order#) = ""
+4 ; or file^field^levDiff (for field type subscripts)
+5 ; DI01(order#) = "" if order # is .01 field
+6 ;
+7 NEW DIKCX,DIKF,DIKO,X1,X2
+8 KILL X,DI01,DINULL
+9 SET DINULL=0
SET (DIKF,DIKO)=$ORDER(@DIKTMP@(DIFILE,DIXR,0))
if 'DIKF
QUIT
+10 ;
+11 if $GET(DION)=""
SET DION=U
+12 FOR
Begin DoDot:1
+13 KILL DIKCX
MERGE DIKCX=X
+14 XECUTE $GET(@DIKTMP@(DIFILE,DIXR,DIKO))
+15 IF $GET(X)]""
IF $DATA(@DIKTMP@(DIFILE,DIXR,DIKO,"T"))
XECUTE @DIKTMP@(DIFILE,DIXR,DIKO,"T")
+16 if $DATA(X)#2
SET (DIKCX,DIKCX(DIKO))=X
KILL X
MERGE X=DIKCX
+17 if $PIECE($GET(@DIKTMP@(DIFILE,DIXR,DIKO,"F")),U,2)=.01
SET DI01(DIKO)=""
+18 IF $GET(X(DIKO))=""
IF $GET(@DIKTMP@(DIFILE,DIXR,DIKO,"SS"))
SET DINULL=1
if $GET(@DIKTMP@(DIFILE,DIXR,DIKO,"F"))
SET DINULL(DIKO)=@DIKTMP@(DIFILE,DIXR,DIKO,"F")
End DoDot:1
SET DIKO=$ORDER(@DIKTMP@(DIFILE,DIXR,DIKO))
if 'DIKO
QUIT
+19 ;
+20 if $DATA(X(DIKF))#2
SET X=$GET(X(DIKF))
+21 QUIT
+22 ;
+23 ;#110 The record is currently locked.
+24 ;#112 The file is currently locked.
