DIK ;SFISC/GFT,YJK,XAK-GATHER A FILE'S XREFS TO EXECUTE ;8NOV2014
;;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.
;
Q:"(,"'[$E($RE(DIK)) Q:'$G(DA) Q:'$D(@(DIK_"DA)")) Q:$P($G(^DD($$GLO^DILIBF(DIK),0,"DI")),U,2)["Y"&'$D(DIOVRD)&'$G(DIFROM) Q:DA'>0
N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIAU,DIKALLR
D CHKS I $D(DIKZ1) N DIKIL S DIKIL=1 G @DIKGP
S X=2 D DD G ^DIK1
;
DD1 N DISKIPIN D D,A Q
;
;
DISKIPIN(DISKIPIN) ;ALSO CALLED FROM DIU1
K DISKIPIN S DISKIPIN=1 D DDGO
F DV=0:0 S DV=$O(^DD("IX","B",+$P($G(@(DIK_"0)")),U,2),DV)) Q:'DV I $G(^DD("IX",DV,"NOREINDEX")) S DISKIPIN=DISKIPIN+1
S DISKIPIN=DISKIPIN-1 Q ;RETURN THE NUMBER OF SKIPPED INDEXES
;
DD ;CALLED FROM DIKZ0
N DISKIPIN
DDGO D DIKJ N DIKCHK S DIKCHK=1,DV=0 D D,A
I $G(DIK(0))["s" S DU=1 Q
E S DV=$O(^DD(DH,"SB",DV))
I DV>0 S DU=$O(^(DV,0)) G E:'$D(^DD(DV,.01,0)),E:$P(^(0),U,2)["W" S DW=$P($P(^DD(DH,DU,0),U,4),";") S:+DW'=DW DW=""""_DW_"""" S DV(DH,DU)=DW,DV(DH,DU,0)=DV,DU(DV)=DH D:$D(DIK0) CRT^DIKZ2 G E
Q:$D(DIK0)
DH S DH=$O(DU(DH)) G:DH>0 DH:$D(DV(DH)),E
F DH=DH(1):0 S DH=$O(DU(DH)) Q:DH'>0 D D,A
DV S DH=0 F S DH=$O(DV(DH)) Q:'DH S DU=0 F S DU=$O(DV(DH,DU)) Q:'DU I $G(DIKCHK),'$G(DIKCHK(DV(DH,DU,0))) S DV(DH,DU,"NOLOOP")=""
S DU=1
Q
;
DW I $O(^UTILITY("DIK",DIKJ,DH,DV,0))="" K ^UTILITY("DIK",DIKJ,DH,DV)
D S DV=$O(^DD(DH,"IX",DV)) Q:DV'>0 I '$D(^DD(DH,DV,0)) K ^DD(DH,"IX",DV) G D
D 0
I F DW=0:0 S DW=$O(^DD(DH,DV,1,DW)) G DW:DW'>0 I $D(^(DW,X)),"Q"'[^(X),$D(^(0)) S %=^(0) D
.I $G(^("NOREINDEX")),$G(DISKIPIN) S DISKIPIN(DISKIPIN)=%,DISKIPIN=DISKIPIN+1 Q
.D INX
;
INX I %["TRIGGER" S %=^(X),^UTILITY("DIK",DIKJ,DH,DV,DW)="D RCR",^(DW,0)=% Q
I %["BULLETIN MESSAGE",$G(DIK(0))["B" S %=$P("CREA^DELE",U,X)_"TE VALUE" W:$D(^(%)) !,"...('"_^(%)_"' BULLETIN WILL NOT BE TRIGGERED)..." Q
I '$D(DIK0),X=2,$P(%,U),$P(%,U,2)]"",$P(%,U,3)="",+%=DH(1)&$G(DIKALLR)!$D(DU(+%)) D
. S ^UTILITY("DIK",DIKJ,"KW",+%,$P(%,U,2))=DH_U_DV_U_DW
. D CHK($G(DU(+%)),.DU,.DIKCHK)
E D
. S ^UTILITY("DIK",DIKJ,DH,DV,DW)=^DD(DH,DV,1,DW,X)
. D CHK(DH,.DU,.DIKCHK)
Q
CHK(F,DU,DIKCHK) ;Set DIKCHK(f) for file F and its parents
Q:$D(DIK0)!'$G(DIKCHK)
F Q:'F Q:$D(DIKCHK(F)) S DIKCHK(F)=1,F=$G(DU(F))
Q
;
A F DV=0:0 S DV=$O(^DD(DH,"AUDIT",DV)) Q:DV'>0 D A1 ;FIND AUDITED FIELDS
Q
A1 D 0 S ^UTILITY("DIK",DIKJ,DH,DV,99)="S DIIX="_(4-X)_" D:$G(DIK(0))'[""A"" AUDIT" D CHK(DH,.DU,.DIKCHK) Q
;
0 ;REMEMBER HOW TO GRAB THE FIELD'S VALUE
S DW=$P(^DD(DH,DV,0),U,4),^UTILITY("DIK",DIKJ,DH,DV)=$P(DW,";",1),DW=$P(DW,";",2)
S ^UTILITY("DIK",DIKJ,DH,DV,0)=$S(DW:"S X=$P($G(^(X)),U,"_DW_")",1:"S X=$E($G(^(X)),"_+$E(DW,2,9)_","_$P(DW,",",2)_")"),DW=0
Q
;
IX ;One entry, all fields, KILL then SET
N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR
D DIK0,CHKS I $D(DIKZ1) N DIKKS S DIKKS=1 D @DIKGP G Q
S X=2,DIKNM=1 D DD,1^DIK1
IX1 ;One entry, all fields, SET (X=1)
N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKSET,DIKALLR
D DIK0 I '$D(DIKNM) D CHKS I $D(DIKZ1) N DIKST S DIKST=1 D @DIKGP G Q
S X=1,DIKSET=1 D DD,1^DIK1
;
D INDEX^DIKC(DIK,.DA,"","",$E("K",$D(DIKNM)#2)_"S"_$E("RI",$D(DIFROM)#2+1)_$E("s",$G(DIK(0))["s"))
G Q
;
IX2 ;One entry, all fields, KILL (X=2)
Q:$D(@(DIK_"0)"))[0
N DIKJ,DIKS,DIN,DH,DU,DV,DW,DIKDA,DIKALLR
S X=2 D DIK0,DD,1^DIK1
D INDEX^DIKC(DIK,.DA,"","","K"_$E("RI",$D(DIFROM)#2+1)_$E("s",$G(DIK(0))["s"))
G Q
;
IXALL ;All entries, SET (X=1)
N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKSET,DIKALLR
N DINO S X=1 D DIK0,DISKIPIN(.DINO)
D CHKS I $D(DIKZ1),'$G(DINO) N DIKSAT S DIKSAT=1,DA=0 D @DIKGP G Q ;CAN'T DO COMPILED ROUTINE IF THERE ARE SOME WE MUST SKIP
;
N DIKDASV,DIKSAVE
M DIKDASV=DA S DIKDASV=0,DIKSAVE=DIK
S (DA,DCNT)=0,X=1,DIKSET=1 D CNT^DIK1
;NOW FIRE NEW-STYLE SETS
D INDEX^DIKC(DIKSAVE,.DIKDASV,"","","Sx"_$E("RI",$D(DIFROM)#2+1)_$E("s",$G(DIK(0))["s"))
G Q
;
IXALL2 ;All entries, KILL (X=2)
Q:$D(@(DIK_"0)"))[0
N DIKJ,DIKS,DIN,DH,DU,DV,DW,DIKDA,DIKDASV,DIKSAVE,DIKALLR
N DINO S X=2 D DIK0,DISKIPIN(.DINO)
M DIKDASV=DA S DIKDASV=0,DIKSAVE=DIK
S DIKALLR=1,(DA,DCNT)=0,X=2 D CNT^DIK1
;NOW FIRE NEW-STYLE KILLS
D INDEX^DIKC(DIKSAVE,.DIKDASV,"","","Kx"_$E("RI",$D(DIFROM)#2+1)_$E("s",$G(DIK(0))["s"))
G Q
;
EN ;One entry, KILL then SET
N DIKCRFIL,DIKCDIK,DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR
D DIK0,N(1) G:'$D(DH)!'$D(DA) Q ;re-indexing
S DIKCRFIL=DH M DIKCDIK=DIK
S DIKNM=1,X=2 D:$D(DIKNX) PR,1^DIK1
;
EN1 ;One entry, SET (X=1)
N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR
D DIK0 D @$S('$D(DIKNM):"N(1)",1:"DIKJ") G:'$D(DH)!'$D(DA) Q ;re-indexing
I '$D(DIKNM) N DIKCRFIL,DIKCDIK S DIKCRFIL=DH M DIKCDIK=DIK
S X=1 D:$D(DIKNX) PR,1^DIK1
I $D(^DD("IX","AC",DIKCRFIL)) M DIK=DIKCDIK D INDEX^DIKC(DIKCRFIL,.DA,$P(DIK(1),U),$P(DIK(1),U,2,999),$E("K",$D(DIKNM))_"S"_$E("RI",$D(DIFROM)#2+1))
G Q
;
EN2 ;One entry, KILL (X=2)
N DIKCRFIL,DIKCDIK,DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR
D DIK0,N(1) G:'$D(DH)!'$D(DA) Q ;re-indexing
S DIKCRFIL=DH M DIKCDIK=DIK
S X=2 D:$D(DIKNX) PR,1^DIK1
I $D(^DD("IX","AC",DIKCRFIL)) M DIK=DIKCDIK D INDEX^DIKC(DIKCRFIL,.DA,$P(DIK(1),U),$P(DIK(1),U,2,999),"K"_$E("RI",$D(DIFROM)#2+1))
G Q
;
ENALL ;All entries, SET (X=1)
N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKXREF,DIKDASV,DIKSAVE,DHSAVE,DIKALLR
D DIK0,N(0) G:'$D(DH) Q ;no re-indexing
M DIKDASV=DA,DIKSAVE=DIK,DHSAVE=DH S DIKDASV=0
S (DA,DCNT)=0,X=1 D PR,CNT^DIK1
D:$D(^DD("IX","AC",DHSAVE)) INDEX^DIKC(DHSAVE,.DIKDASV,$P(DIKSAVE(1),U),$P(DIKSAVE(1),U,2,999),"Sx"_$E("RI",$D(DIFROM)#2+1))
G Q
;
ENALL2 ;All entries, KILL (X=2)
N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKXREF,DIKDASV,DIKSAVE,DHSAVE,DIKALLR
D DIK0,N(0) G:'$D(DH) Q ;no re-indexing
M DIKDASV=DA,DIKSAVE=DIK,DHSAVE=DH S DIKDASV=0
S DIKALLR=1,(DA,DCNT)=0,X=2 D PR,CNT^DIK1
D:$D(^DD("IX","AC",DHSAVE)) INDEX^DIKC(DHSAVE,.DIKDASV,$P(DIKSAVE(1),U),$P(DIKSAVE(1),U,2,999),"Kx"_$E("RI",$D(DIFROM)#2+1))
G Q
;
;
N(REINDOK) Q:'$D(DIK)!'$D(DIK(1))!'$D(@(DIK_"0)")) D DIKJ S DIKND=$P(DIK(1),U)
I '$D(^DD(DH,"IX",DIKND)) K:'$D(^DD("IX","F",DH,DIKND)) DH Q
I $P(DIK(1),U,2)="" D
. S %=0 F A1=1:1 S %=$O(^DD(DH,DIKND,1,%)) Q:'% I '$G(^(%,"NOREINDEX"))!REINDOK S DIKNX(A1)=% ;SKIP NON-RERUNNABLE INDEX IF NOT SPECIFIED PRECISELY AND IF THIS IS A MASS REINDEX
E F A1=1:1 Q:$P(DIK(1),U,A1+1)="" S DIKNX(A1)=$P(DIK(1),U,A1+1)
K A1,% Q
;
PR S DV=DIKND I '$D(^DD(DH,"IX",DV)),'$D(^DD(DH,"AUDIT",DV)) Q
D 0 S DIKZ1=$O(DIKNX(0)) D:DIKZ1 CK K DIKZ1 ; - VEN/SMH
D:$D(^DD(DH,"AUDIT",DV)) A1 S DU=1 Q
;
CK Q:'$D(DIKNX(+DIKZ1))
F DW=0:0 S DW=$O(^DD(DH,DV,1,DW)) Q:DW'>0 I $D(^(DW,0)),(DW=DIKNX(DIKZ1))!($P(^(0),U,2)=DIKNX(DIKZ1)),$D(^(X)),"Q"'[^(X) S %=^(0) D INX
S DIKZ1=$O(DIKNX(+DIKZ1)) G CK
;
FREE(X) N V S V=$G(^UTILITY("DIK",X)) I 'V Q 1
Q $H-1>V
;
DIKJ F DIKJ=$J:.01 I $$FREE(DIKJ) K ^UTILITY("DIK",DIKJ) S ^UTILITY("DIK",DIKJ)=$H Q ;TO ENABLE RECURSIVE CALL, FIND A "$J" THAT'S UNUSED
INT K DIKS,DIN,DH,DU,DV,DW S U="^",DH=+$P(@(DIK_"0)"),U,2),DH(1)=DH Q
;
CHKS ;
I $D(@(DIK_"0)"))[0 S DIKZ1=1,DIKGP="Q^DIK1" Q
S DIKZ1=+$P(^(0),"^",2) I DIKZ1,$D(^DD(DIKZ1,0,"DIK")),$$ROUEXIST^DILIBF(^("DIK")) S DIKGP="^"_^DD(DIKZ1,0,"DIK") Q
K DIKZ1 Q
;
DIK0 I '$D(DIK(0)) S DIK(0)="A666" ;MASS CROSS-REFERENCES SHOULD NOT FILL UP THE AUDIT FILE (^DIA)
Q
;
Q K:$G(DIK(0))["A666" DIK(0) K DIKND,DIKNX,DIKZ1,DIKNM,DIAU,DIG,DIH,DIV,DIW,%,DH Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIK 7710 printed Sep 23, 2025@20:24:44 Page 2
DIK ;SFISC/GFT,YJK,XAK-GATHER A FILE'S XREFS TO EXECUTE ;8NOV2014
+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 ;
+7 if "(,"'[$EXTRACT($REVERSE(DIK))
QUIT
if '$GET(DA)
QUIT
if '$DATA(@(DIK_"DA)"))
QUIT
if $PIECE($GET(^DD($$GLO^DILIBF(DIK),0,"DI")),U,2)["Y"&'$DATA(DIOVRD)&'$GET(DIFROM)
QUIT
if DA'>0
QUIT
+8 NEW DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIAU,DIKALLR
+9 DO CHKS
IF $DATA(DIKZ1)
NEW DIKIL
SET DIKIL=1
GOTO @DIKGP
+10 SET X=2
DO DD
GOTO ^DIK1
+11 ;
DD1 NEW DISKIPIN
DO D
DO A
QUIT
+1 ;
+2 ;
DISKIPIN(DISKIPIN) ;ALSO CALLED FROM DIU1
+1 KILL DISKIPIN
SET DISKIPIN=1
DO DDGO
+2 FOR DV=0:0
SET DV=$ORDER(^DD("IX","B",+$PIECE($GET(@(DIK_"0)")),U,2),DV))
if 'DV
QUIT
IF $GET(^DD("IX",DV,"NOREINDEX"))
SET DISKIPIN=DISKIPIN+1
+3 ;RETURN THE NUMBER OF SKIPPED INDEXES
SET DISKIPIN=DISKIPIN-1
QUIT
+4 ;
DD ;CALLED FROM DIKZ0
+1 NEW DISKIPIN
DDGO DO DIKJ
NEW DIKCHK
SET DIKCHK=1
SET DV=0
DO D
DO A
+1 IF $GET(DIK(0))["s"
SET DU=1
QUIT
E SET DV=$ORDER(^DD(DH,"SB",DV))
+1 IF DV>0
SET DU=$ORDER(^(DV,0))
if '$DATA(^DD(DV,.01,0))
GOTO E
if $PIECE(^(0),U,2)["W"
GOTO E
SET DW=$PIECE($PIECE(^DD(DH,DU,0),U,4),";")
if +DW'=DW
SET DW=""""_DW_""""
SET DV(DH,DU)=DW
SET DV(DH,DU,0)=DV
SET DU(DV)=DH
if $DATA(DIK0)
DO CRT^DIKZ2
GOTO E
+2 if $DATA(DIK0)
QUIT
DH SET DH=$ORDER(DU(DH))
if DH>0
if $DATA(DV(DH))
GOTO DH
GOTO E
+1 FOR DH=DH(1):0
SET DH=$ORDER(DU(DH))
if DH'>0
QUIT
DO D
DO A
DV SET DH=0
FOR
SET DH=$ORDER(DV(DH))
if 'DH
QUIT
SET DU=0
FOR
SET DU=$ORDER(DV(DH,DU))
if 'DU
QUIT
IF $GET(DIKCHK)
IF '$GET(DIKCHK(DV(DH,DU,0)))
SET DV(DH,DU,"NOLOOP")=""
+1 SET DU=1
+2 QUIT
+3 ;
DW IF $ORDER(^UTILITY("DIK",DIKJ,DH,DV,0))=""
KILL ^UTILITY("DIK",DIKJ,DH,DV)
D SET DV=$ORDER(^DD(DH,"IX",DV))
if DV'>0
QUIT
IF '$DATA(^DD(DH,DV,0))
KILL ^DD(DH,"IX",DV)
GOTO D
+1 DO 0
I FOR DW=0:0
SET DW=$ORDER(^DD(DH,DV,1,DW))
if DW'>0
GOTO DW
IF $DATA(^(DW,X))
IF "Q"'[^(X)
IF $DATA(^(0))
SET %=^(0)
Begin DoDot:1
+1 IF $GET(^("NOREINDEX"))
IF $GET(DISKIPIN)
SET DISKIPIN(DISKIPIN)=%
SET DISKIPIN=DISKIPIN+1
QUIT
+2 DO INX
End DoDot:1
+3 ;
INX IF %["TRIGGER"
SET %=^(X)
SET ^UTILITY("DIK",DIKJ,DH,DV,DW)="D RCR"
SET ^(DW,0)=%
QUIT
+1 IF %["BULLETIN MESSAGE"
IF $GET(DIK(0))["B"
SET %=$PIECE("CREA^DELE",U,X)_"TE VALUE"
if $DATA(^(%))
WRITE !,"...('"_^(%)_"' BULLETIN WILL NOT BE TRIGGERED)..."
QUIT
+2 IF '$DATA(DIK0)
IF X=2
IF $PIECE(%,U)
IF $PIECE(%,U,2)]""
IF $PIECE(%,U,3)=""
IF +%=DH(1)&$GET(DIKALLR)!$DATA(DU(+%))
Begin DoDot:1
+3 SET ^UTILITY("DIK",DIKJ,"KW",+%,$PIECE(%,U,2))=DH_U_DV_U_DW
+4 DO CHK($GET(DU(+%)),.DU,.DIKCHK)
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET ^UTILITY("DIK",DIKJ,DH,DV,DW)=^DD(DH,DV,1,DW,X)
+7 DO CHK(DH,.DU,.DIKCHK)
End DoDot:1
+8 QUIT
CHK(F,DU,DIKCHK) ;Set DIKCHK(f) for file F and its parents
+1 if $DATA(DIK0)!'$GET(DIKCHK)
QUIT
+2 FOR
if 'F
QUIT
if $DATA(DIKCHK(F))
QUIT
SET DIKCHK(F)=1
SET F=$GET(DU(F))
+3 QUIT
+4 ;
A ;FIND AUDITED FIELDS
FOR DV=0:0
SET DV=$ORDER(^DD(DH,"AUDIT",DV))
if DV'>0
QUIT
DO A1
+1 QUIT
A1 DO 0
SET ^UTILITY("DIK",DIKJ,DH,DV,99)="S DIIX="_(4-X)_" D:$G(DIK(0))'[""A"" AUDIT"
DO CHK(DH,.DU,.DIKCHK)
QUIT
+1 ;
0 ;REMEMBER HOW TO GRAB THE FIELD'S VALUE
+1 SET DW=$PIECE(^DD(DH,DV,0),U,4)
SET ^UTILITY("DIK",DIKJ,DH,DV)=$PIECE(DW,";",1)
SET DW=$PIECE(DW,";",2)
+2 SET ^UTILITY("DIK",DIKJ,DH,DV,0)=$SELECT(DW:"S X=$P($G(^(X)),U,"_DW_")",1:"S X=$E($G(^(X)),"_+$EXTRACT(DW,2,9)_","_$PIECE(DW,",",2)_")")
SET DW=0
+3 QUIT
+4 ;
IX ;One entry, all fields, KILL then SET
+1 NEW DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR
+2 DO DIK0
DO CHKS
IF $DATA(DIKZ1)
NEW DIKKS
SET DIKKS=1
DO @DIKGP
GOTO Q
+3 SET X=2
SET DIKNM=1
DO DD
DO 1^DIK1
IX1 ;One entry, all fields, SET (X=1)
+1 NEW DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKSET,DIKALLR
+2 DO DIK0
IF '$DATA(DIKNM)
DO CHKS
IF $DATA(DIKZ1)
NEW DIKST
SET DIKST=1
DO @DIKGP
GOTO Q
+3 SET X=1
SET DIKSET=1
DO DD
DO 1^DIK1
+4 ;
+5 DO INDEX^DIKC(DIK,.DA,"","",$EXTRACT("K",$DATA(DIKNM)#2)_"S"_$EXTRACT("RI",$DATA(DIFROM)#2+1)_$EXTRACT("s",$GET(DIK(0))["s"))
+6 GOTO Q
+7 ;
IX2 ;One entry, all fields, KILL (X=2)
+1 if $DATA(@(DIK_"0)"))[0
QUIT
+2 NEW DIKJ,DIKS,DIN,DH,DU,DV,DW,DIKDA,DIKALLR
+3 SET X=2
DO DIK0
DO DD
DO 1^DIK1
+4 DO INDEX^DIKC(DIK,.DA,"","","K"_$EXTRACT("RI",$DATA(DIFROM)#2+1)_$EXTRACT("s",$GET(DIK(0))["s"))
+5 GOTO Q
+6 ;
IXALL ;All entries, SET (X=1)
+1 NEW DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKSET,DIKALLR
+2 NEW DINO
SET X=1
DO DIK0
DO DISKIPIN(.DINO)
+3 ;CAN'T DO COMPILED ROUTINE IF THERE ARE SOME WE MUST SKIP
DO CHKS
IF $DATA(DIKZ1)
IF '$GET(DINO)
NEW DIKSAT
SET DIKSAT=1
SET DA=0
DO @DIKGP
GOTO Q
+4 ;
+5 NEW DIKDASV,DIKSAVE
+6 MERGE DIKDASV=DA
SET DIKDASV=0
SET DIKSAVE=DIK
+7 SET (DA,DCNT)=0
SET X=1
SET DIKSET=1
DO CNT^DIK1
+8 ;NOW FIRE NEW-STYLE SETS
+9 DO INDEX^DIKC(DIKSAVE,.DIKDASV,"","","Sx"_$EXTRACT("RI",$DATA(DIFROM)#2+1)_$EXTRACT("s",$GET(DIK(0))["s"))
+10 GOTO Q
+11 ;
IXALL2 ;All entries, KILL (X=2)
+1 if $DATA(@(DIK_"0)"))[0
QUIT
+2 NEW DIKJ,DIKS,DIN,DH,DU,DV,DW,DIKDA,DIKDASV,DIKSAVE,DIKALLR
+3 NEW DINO
SET X=2
DO DIK0
DO DISKIPIN(.DINO)
+4 MERGE DIKDASV=DA
SET DIKDASV=0
SET DIKSAVE=DIK
+5 SET DIKALLR=1
SET (DA,DCNT)=0
SET X=2
DO CNT^DIK1
+6 ;NOW FIRE NEW-STYLE KILLS
+7 DO INDEX^DIKC(DIKSAVE,.DIKDASV,"","","Kx"_$EXTRACT("RI",$DATA(DIFROM)#2+1)_$EXTRACT("s",$GET(DIK(0))["s"))
+8 GOTO Q
+9 ;
EN ;One entry, KILL then SET
+1 NEW DIKCRFIL,DIKCDIK,DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR
+2 ;re-indexing
DO DIK0
DO N(1)
if '$DATA(DH)!'$DATA(DA)
GOTO Q
+3 SET DIKCRFIL=DH
MERGE DIKCDIK=DIK
+4 SET DIKNM=1
SET X=2
if $DATA(DIKNX)
DO PR
DO 1^DIK1
+5 ;
EN1 ;One entry, SET (X=1)
+1 NEW DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR
+2 ;re-indexing
DO DIK0
DO @$SELECT('$DATA(DIKNM):"N(1)",1:"DIKJ")
if '$DATA(DH)!'$DATA(DA)
GOTO Q
+3 IF '$DATA(DIKNM)
NEW DIKCRFIL,DIKCDIK
SET DIKCRFIL=DH
MERGE DIKCDIK=DIK
+4 SET X=1
if $DATA(DIKNX)
DO PR
DO 1^DIK1
+5 IF $DATA(^DD("IX","AC",DIKCRFIL))
MERGE DIK=DIKCDIK
DO INDEX^DIKC(DIKCRFIL,.DA,$PIECE(DIK(1),U),$PIECE(DIK(1),U,2,999),$EXTRACT("K",$DATA(DIKNM))_"S"_$EXTRACT("RI",$DATA(DIFROM)#2+1))
+6 GOTO Q
+7 ;
EN2 ;One entry, KILL (X=2)
+1 NEW DIKCRFIL,DIKCDIK,DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR
+2 ;re-indexing
DO DIK0
DO N(1)
if '$DATA(DH)!'$DATA(DA)
GOTO Q
+3 SET DIKCRFIL=DH
MERGE DIKCDIK=DIK
+4 SET X=2
if $DATA(DIKNX)
DO PR
DO 1^DIK1
+5 IF $DATA(^DD("IX","AC",DIKCRFIL))
MERGE DIK=DIKCDIK
DO INDEX^DIKC(DIKCRFIL,.DA,$PIECE(DIK(1),U),$PIECE(DIK(1),U,2,999),"K"_$EXTRACT("RI",$DATA(DIFROM)#2+1))
+6 GOTO Q
+7 ;
ENALL ;All entries, SET (X=1)
+1 NEW DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKXREF,DIKDASV,DIKSAVE,DHSAVE,DIKALLR
+2 ;no re-indexing
DO DIK0
DO N(0)
if '$DATA(DH)
GOTO Q
+3 MERGE DIKDASV=DA,DIKSAVE=DIK,DHSAVE=DH
SET DIKDASV=0
+4 SET (DA,DCNT)=0
SET X=1
DO PR
DO CNT^DIK1
+5 if $DATA(^DD("IX","AC",DHSAVE))
DO INDEX^DIKC(DHSAVE,.DIKDASV,$PIECE(DIKSAVE(1),U),$PIECE(DIKSAVE(1),U,2,999),"Sx"_$EXTRACT("RI",$DATA(DIFROM)#2+1))
+6 GOTO Q
+7 ;
ENALL2 ;All entries, KILL (X=2)
+1 NEW DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKXREF,DIKDASV,DIKSAVE,DHSAVE,DIKALLR
+2 ;no re-indexing
DO DIK0
DO N(0)
if '$DATA(DH)
GOTO Q
+3 MERGE DIKDASV=DA,DIKSAVE=DIK,DHSAVE=DH
SET DIKDASV=0
+4 SET DIKALLR=1
SET (DA,DCNT)=0
SET X=2
DO PR
DO CNT^DIK1
+5 if $DATA(^DD("IX","AC",DHSAVE))
DO INDEX^DIKC(DHSAVE,.DIKDASV,$PIECE(DIKSAVE(1),U),$PIECE(DIKSAVE(1),U,2,999),"Kx"_$EXTRACT("RI",$DATA(DIFROM)#2+1))
+6 GOTO Q
+7 ;
+8 ;
N(REINDOK) if '$DATA(DIK)!'$DATA(DIK(1))!'$DATA(@(DIK_"0)"))
QUIT
DO DIKJ
SET DIKND=$PIECE(DIK(1),U)
+1 IF '$DATA(^DD(DH,"IX",DIKND))
if '$DATA(^DD("IX","F",DH,DIKND))
KILL DH
QUIT
+2 IF $PIECE(DIK(1),U,2)=""
Begin DoDot:1
+3 ;SKIP NON-RERUNNABLE INDEX IF NOT SPECIFIED PRECISELY AND IF THIS IS A MASS REINDEX
SET %=0
FOR A1=1:1
SET %=$ORDER(^DD(DH,DIKND,1,%))
if '%
QUIT
IF '$GET(^(%,"NOREINDEX"))!REINDOK
SET DIKNX(A1)=%
End DoDot:1
+4 IF '$TEST
FOR A1=1:1
if $PIECE(DIK(1),U,A1+1)=""
QUIT
SET DIKNX(A1)=$PIECE(DIK(1),U,A1+1)
+5 KILL A1,%
QUIT
+6 ;
PR SET DV=DIKND
IF '$DATA(^DD(DH,"IX",DV))
IF '$DATA(^DD(DH,"AUDIT",DV))
QUIT
+1 ; - VEN/SMH
DO 0
SET DIKZ1=$ORDER(DIKNX(0))
if DIKZ1
DO CK
KILL DIKZ1
+2 if $DATA(^DD(DH,"AUDIT",DV))
DO A1
SET DU=1
QUIT
+3 ;
CK if '$DATA(DIKNX(+DIKZ1))
QUIT
+1 FOR DW=0:0
SET DW=$ORDER(^DD(DH,DV,1,DW))
if DW'>0
QUIT
IF $DATA(^(DW,0))
IF (DW=DIKNX(DIKZ1))!($PIECE(^(0),U,2)=DIKNX(DIKZ1))
IF $DATA(^(X))
IF "Q"'[^(X)
SET %=^(0)
DO INX
+2 SET DIKZ1=$ORDER(DIKNX(+DIKZ1))
GOTO CK
+3 ;
FREE(X) NEW V
SET V=$GET(^UTILITY("DIK",X))
IF 'V
QUIT 1
+1 QUIT $HOROLOG-1>V
+2 ;
DIKJ ;TO ENABLE RECURSIVE CALL, FIND A "$J" THAT'S UNUSED
FOR DIKJ=$JOB:.01
IF $$FREE(DIKJ)
KILL ^UTILITY("DIK",DIKJ)
SET ^UTILITY("DIK",DIKJ)=$HOROLOG
QUIT
INT KILL DIKS,DIN,DH,DU,DV,DW
SET U="^"
SET DH=+$PIECE(@(DIK_"0)"),U,2)
SET DH(1)=DH
QUIT
+1 ;
CHKS ;
+1 IF $DATA(@(DIK_"0)"))[0
SET DIKZ1=1
SET DIKGP="Q^DIK1"
QUIT
+2 SET DIKZ1=+$PIECE(^(0),"^",2)
IF DIKZ1
IF $DATA(^DD(DIKZ1,0,"DIK"))
IF $$ROUEXIST^DILIBF(^("DIK"))
SET DIKGP="^"_^DD(DIKZ1,0,"DIK")
QUIT
+3 KILL DIKZ1
QUIT
+4 ;
DIK0 ;MASS CROSS-REFERENCES SHOULD NOT FILL UP THE AUDIT FILE (^DIA)
IF '$DATA(DIK(0))
SET DIK(0)="A666"
+1 QUIT
+2 ;
Q if $GET(DIK(0))["A666"
KILL DIK(0)
KILL DIKND,DIKNX,DIKZ1,DIKNM,DIAU,DIG,DIH,DIV,DIW,%,DH
QUIT
