DIU1 ;SFISC/GFT-REINDEX A FILE ;6NOV2012
;;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.
;
4 ;RE-CROSS-REFERENCING -- UTILITY OPTION 4
N DIUCNT,DIUTYPE,DV,DU,DW,DINO,DIKJ ;COME IN WITH I,J,N DEFINED
W !! K ^UTILITY("DIK",$J),X S DIK=DIU,X=0 D DISKIPIN^DIK(.DINO) S DW=0,DIUF=DI ;USED TO CALL D DD^DIK
DW S DW=$O(^UTILITY("DIK",$J,DW)),DV=0 S:DW="" DW=-1
I DW>0 S DU=0 F S DV=$O(^UTILITY("DIK",$J,DW,DV)),DH=0 G DW:DV="" S Y=0 F S DH=$O(^UTILITY("DIK",$J,DW,DV,DH)) Q:DH="" D
.S Y=^UTILITY("DIK",$J,DW,DV,DH),X=X+1,X(X)=Y,X(X,0)=DW_U_DV S:$P(Y,U,3)=""&'Y&$D(^(DH,0)) X(X)=^(0)
D GETXR^DIKCUTL2(DI,.DIUCNT,"xM")
F %=1:1:X I $G(X(%))="S DIIX=4 D:$G(DIK(0))'[""A"" AUDIT" K X(%) S X=X-1 F Y=%:1:X M X(Y)=X(Y+1) K X(Y+1) S %=%-1
K ^UTILITY("DIK",$J) G DD:'(X+DIUCNT),ONE:(X+DIUCNT)>1
ALL W "OK, ARE YOU SURE YOU WANT TO KILL OFF THE EXISTING "
I X=0,DIUCNT=1 W "'"_$P(DIUCNT($O(DIUCNT(""))),U,3)_"' INDEX"
E I X=1,DIUCNT=0 W $P(^DD(+X(1,0),$P(X(1,0),U,2),0),U,1)_" INDEX"
E W X+DIUCNT_" INDICES"
S %=2 D YN^DICN G:%-1 NO:%,Q W !,"DO YOU THEN WANT TO 'RE-CROSS-REFERENCE'" D YN^DICN G NO:%<1 S N=%=1 D WAIT^DICD
F X=X:-1:1 S %=$P(X(X),U,2) I %]"",+X(X)=DI K @(DIK_"%)") K:$P(X(X),U,3)'="MUMPS" X(X)
;THE REMAINING NODES OF 'X' SAY THAT WE HAVE TO KILL SOME INDIVIDUALLY.
;DIK(0)="AB" MEANS 'DON'T AUDIT & DON'T DO BULLETINS';X=2 MEANS DO KILLING. THAT OCCURS IN CNT^DIK1
S DIK(0)="ABX" I $O(X(0))]"" S X=2,(DA,DCNT)=0 D DISKIPIN^DIK(.DINO),CNT^DIK1
D:DIUCNT INDEX^DIKC(DIUF,"","","","KR") ;NOW DELETE THE NEW-STYLES, IF ANY
K X I N W !,$C(7),"FILE WILL NOW BE 'RE-CROSS-REFERENCED'..." H 5 D DD S DIK=^DIC(DIUF,0,"GL") D IXALL^DIK
K DIK,DIC Q
;
DD S DIK="^DD(DI,",DA(1)=DI K ^DD(DI,"B"),^("GL"),^("IX"),^("RQ"),^("GR"),^("SB")
W "." D IXALL^DIK:$D(^(0))#2 S DI=$O(^DD(DI)) S:DI="" DI=-1 I DI>0,DI<$O(^DIC(DIUF)) G DD ;RE-DOES THE DATA DICTIONARY, NOT THE DATA
Q
;
ONE S %=2 W "THERE ARE "_(X+DIUCNT)_$P(" RE-RUNNABLE",U,DINO>0)_" INDICES WITHIN THIS FILE",!,"DO YOU WISH TO RE-CROSS-REFERENCE ONE PARTICULAR INDEX" D YN^DICN W ! I %-1 G ALL:%=2,NO:%,Q
S DIUTYPE=$S('$G(DIUCNT):1,'$G(X):2,1:$$TYPE^DIKCUTL2)
G NO:DIUTYPE=""
I DIUTYPE=2 K DIUCNT D ONEXR(DI) Q
K X S X="CRW" D DI^DIU G NO:Y<0 S (DA,DL)=+Y,DICD="RE-CROSS-REFERENCE" D CHIX^DICD G NO:'DICD
S X=$P(I,U,2),%=$S(X]"":"THE '"_X_"' INDEX",1:"THIS TRIGGER") I $G(^DD(DI,DA,1,DICD,"NOREINDEX")) W !,"SORRY. ",%," IS LISTED AS NOT RE-RUNNABLE" G NO
W !,"ARE YOU SURE YOU WANT TO DELETE AND RE-CROSS-REFERENCE "_% S %=2 D YN^DICN G NO:%-1
G IND:X="" F %=0:0 S %=$O(^DD(+I,0,"IX",X,%)) Q:%="" F %Y=0:0 S %Y=$O(^DD(+I,0,"IX",X,%,%Y)) Q:%Y="" I %Y-DA!(%-DI) G IND
I +I=DIUF,$P(I,U,3)="",X]"" K @(DIK_"X)") G REDO
IND I $P(I,U,3)="",X]"" D KWREG(DIU,0,.I,.J) G REDO
S X=^DD(J(N),DA,1,DICD,2) D DD^DICD:"Q"'[X S DIU=^DIC(DIUF,0,"GL")
REDO S X=^DD(J(N),DL,1,DICD,1) D DD^DICD:"Q"'[X W $C(7)," ...DONE!" Q
;
Q F I=1:1:X W !,"FIELD " S %=X(I,0),J=$P(%,U,2) W J_" ('"_$P(^DD(+%,J,0),U,1)_"'" W:%-DI ", "_$O(^DD(+%,0,"NM",0))_" SUBFILE" W ") IS ",$S(X(I):"'"_$P(X(I),U,2)_"' INDEX",1:$P(X(I),U,3)) D UP
W !! D LIST^DIKCUTL2(.DIUCNT,"INDEX FILE CROSS-REFERENCES:")
G 4
UP I X(I),X(I)-DI S %=$D(^DD(+X(I),0,"UP")) W " OF "_$O(^("NM",0))_" "_$P("SUB",U,%>0)_"FILE" Q
S %=+$P(X(I),U,4),(%F,Y)=+$P(X(I),U,5) I %,$D(^DD(%,Y,0)) W:$X>44 ! W " OF " D WR^DIDH
Q
;
NO W !?7,$C(7),"<NO ACTION TAKEN>" K DICD,X,DH
Q
;
KWREG(ROOT,LEV,I,J) ;Kill entire regular index
;In:
; ROOT = open root of file or subfile
; LEV = level # of ROOT
; I = ^DD(file#,field#,1,xref#,0) [xref header node] = rfile#^name
; I(N) = node on which multiple at level n resides (for N>0)
; J(N) = level N subfile #
;
N CROOT
S CROOT=$$CREF^DILF(ROOT)
Q:'$D(@CROOT)
I J(LEV)=+I K @CROOT@($P(I,U,2)) Q
;
N DA
S DA=0
F S DA=$O(@CROOT@(DA)) Q:'DA D:$D(@CROOT@(DA,0))#2 KWREG(ROOT_DA_","_I(LEV+1)_",",LEV+1,.I,.J)
Q
;
;==============
; ONEXR(file#)
;==============
;Prompt for file/subfile and Index; run kill/set logic for that Index
;In:
; DI = top level file #
;
ONEXR(DI) ;Re-index one cross reference
;Prompt for subfile
N DIUCNT,DIUCTRL,DIUFILE,DIULOG,DIUXR
W !!?10,"File: "_$O(^DD(DI,0,"NM",""))_" (#"_DI_")"
S DIUFILE=$$SUB^DIKCU(DI) G:DIUFILE="" NO
;
;Prompt for xref
D GETXR^DIKCUTL2(DIUFILE,.DIUCNT,"x")
W ! D LIST^DIKCUTL2(.DIUCNT)
S DIUXR=$$CHOOSE^DIKCUTL2(.DIUCNT,"re-cross-reference")
G:'DIUXR NO
;
;Run kill and/or set
S DIUCTRL=$$LOGIC($P(DIUCNT(DIUXR),U,3))
G:DIUCTRL="" NO
;
S:DI'=DIUFILE DIUCTRL=DIUCTRL_"W"_DIUFILE
D INDEX^DIKC(DI,"","",DIUXR,DIUCTRL_"R")
W $C(7)_" ...DONE!"
Q
;
;====================
; $$LOGIC(indexName)
;====================
;Prompt for whether kill and/or set logic should be run.
;In:
; DIUNAME = name of xref (used in prompt)
;Return value:
; [ K : if kill logic should be run
; [ S : if set logic should be run
;
LOGIC(DIUNAME) ;
N DIULOG,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIULOG=""
;
;Ask whether kill logic should be executed
S DIR(0)="Y"
S DIR("A")="Do you want to delete the existing '"_DIUNAME_"' cross-reference"
S DIR("?")=" Enter 'YES' if you want to run the kill logic for this cross-reference."
W ! D ^DIR K DIR Q:$D(DIRUT) ""
S:Y DIULOG="K"
;
;Ask whether set logic should be executed
S DIR(0)="Y"
S DIR("A")="Do you want to re-build the '"_DIUNAME_"' cross reference"
S DIR("?")=" Enter 'YES' if you want to run the set logic for this cross reference."
D ^DIR K DIR Q:$D(DIRUT) ""
S:Y DIULOG=DIULOG_"S"
Q DIULOG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIU1 5872 printed Sep 23, 2025@20:30:40 Page 2
DIU1 ;SFISC/GFT-REINDEX A FILE ;6NOV2012
+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 ;
4 ;RE-CROSS-REFERENCING -- UTILITY OPTION 4
+1 ;COME IN WITH I,J,N DEFINED
NEW DIUCNT,DIUTYPE,DV,DU,DW,DINO,DIKJ
+2 ;USED TO CALL D DD^DIK
WRITE !!
KILL ^UTILITY("DIK",$JOB),X
SET DIK=DIU
SET X=0
DO DISKIPIN^DIK(.DINO)
SET DW=0
SET DIUF=DI
DW SET DW=$ORDER(^UTILITY("DIK",$JOB,DW))
SET DV=0
if DW=""
SET DW=-1
+1 IF DW>0
SET DU=0
FOR
SET DV=$ORDER(^UTILITY("DIK",$JOB,DW,DV))
SET DH=0
if DV=""
GOTO DW
SET Y=0
FOR
SET DH=$ORDER(^UTILITY("DIK",$JOB,DW,DV,DH))
if DH=""
QUIT
Begin DoDot:1
+2 SET Y=^UTILITY("DIK",$JOB,DW,DV,DH)
SET X=X+1
SET X(X)=Y
SET X(X,0)=DW_U_DV
if $PIECE(Y,U,3)=""&'Y&$DATA(^(DH,0))
SET X(X)=^(0)
End DoDot:1
+3 DO GETXR^DIKCUTL2(DI,.DIUCNT,"xM")
+4 FOR %=1:1:X
IF $GET(X(%))="S DIIX=4 D:$G(DIK(0))'[""A"" AUDIT"
KILL X(%)
SET X=X-1
FOR Y=%:1:X
MERGE X(Y)=X(Y+1)
KILL X(Y+1)
SET %=%-1
+5 KILL ^UTILITY("DIK",$JOB)
if '(X+DIUCNT)
GOTO DD
if (X+DIUCNT)>1
GOTO ONE
ALL WRITE "OK, ARE YOU SURE YOU WANT TO KILL OFF THE EXISTING "
+1 IF X=0
IF DIUCNT=1
WRITE "'"_$PIECE(DIUCNT($ORDER(DIUCNT(""))),U,3)_"' INDEX"
+2 IF '$TEST
IF X=1
IF DIUCNT=0
WRITE $PIECE(^DD(+X(1,0),$PIECE(X(1,0),U,2),0),U,1)_" INDEX"
+3 IF '$TEST
WRITE X+DIUCNT_" INDICES"
+4 SET %=2
DO YN^DICN
if %-1
if %
GOTO NO
GOTO Q
WRITE !,"DO YOU THEN WANT TO 'RE-CROSS-REFERENCE'"
DO YN^DICN
if %<1
GOTO NO
SET N=%=1
DO WAIT^DICD
+5 FOR X=X:-1:1
SET %=$PIECE(X(X),U,2)
IF %]""
IF +X(X)=DI
KILL @(DIK_"%)")
if $PIECE(X(X),U,3)'="MUMPS"
KILL X(X)
+6 ;THE REMAINING NODES OF 'X' SAY THAT WE HAVE TO KILL SOME INDIVIDUALLY.
+7 ;DIK(0)="AB" MEANS 'DON'T AUDIT & DON'T DO BULLETINS';X=2 MEANS DO KILLING. THAT OCCURS IN CNT^DIK1
+8 SET DIK(0)="ABX"
IF $ORDER(X(0))]""
SET X=2
SET (DA,DCNT)=0
DO DISKIPIN^DIK(.DINO)
DO CNT^DIK1
+9 ;NOW DELETE THE NEW-STYLES, IF ANY
if DIUCNT
DO INDEX^DIKC(DIUF,"","","","KR")
+10 KILL X
IF N
WRITE !,$CHAR(7),"FILE WILL NOW BE 'RE-CROSS-REFERENCED'..."
HANG 5
DO DD
SET DIK=^DIC(DIUF,0,"GL")
DO IXALL^DIK
+11 KILL DIK,DIC
QUIT
+12 ;
DD SET DIK="^DD(DI,"
SET DA(1)=DI
KILL ^DD(DI,"B"),^("GL"),^("IX"),^("RQ"),^("GR"),^("SB")
+1 ;RE-DOES THE DATA DICTIONARY, NOT THE DATA
WRITE "."
if $DATA(^(0))#2
DO IXALL^DIK
SET DI=$ORDER(^DD(DI))
if DI=""
SET DI=-1
IF DI>0
IF DI<$ORDER(^DIC(DIUF))
GOTO DD
+2 QUIT
+3 ;
ONE SET %=2
WRITE "THERE ARE "_(X+DIUCNT)_$PIECE(" RE-RUNNABLE",U,DINO>0)_" INDICES WITHIN THIS FILE",!,"DO YOU WISH TO RE-CROSS-REFERENCE ONE PARTICULAR INDEX"
DO YN^DICN
WRITE !
IF %-1
if %=2
GOTO ALL
if %
GOTO NO
GOTO Q
+1 SET DIUTYPE=$SELECT('$GET(DIUCNT):1,'$GET(X):2,1:$$TYPE^DIKCUTL2)
+2 if DIUTYPE=""
GOTO NO
+3 IF DIUTYPE=2
KILL DIUCNT
DO ONEXR(DI)
QUIT
+4 KILL X
SET X="CRW"
DO DI^DIU
if Y<0
GOTO NO
SET (DA,DL)=+Y
SET DICD="RE-CROSS-REFERENCE"
DO CHIX^DICD
if 'DICD
GOTO NO
+5 SET X=$PIECE(I,U,2)
SET %=$SELECT(X]"":"THE '"_X_"' INDEX",1:"THIS TRIGGER")
IF $GET(^DD(DI,DA,1,DICD,"NOREINDEX"))
WRITE !,"SORRY. ",%," IS LISTED AS NOT RE-RUNNABLE"
GOTO NO
+6 WRITE !,"ARE YOU SURE YOU WANT TO DELETE AND RE-CROSS-REFERENCE "_%
SET %=2
DO YN^DICN
if %-1
GOTO NO
+7 if X=""
GOTO IND
FOR %=0:0
SET %=$ORDER(^DD(+I,0,"IX",X,%))
if %=""
QUIT
FOR %Y=0:0
SET %Y=$ORDER(^DD(+I,0,"IX",X,%,%Y))
if %Y=""
QUIT
IF %Y-DA!(%-DI)
GOTO IND
+8 IF +I=DIUF
IF $PIECE(I,U,3)=""
IF X]""
KILL @(DIK_"X)")
GOTO REDO
IND IF $PIECE(I,U,3)=""
IF X]""
DO KWREG(DIU,0,.I,.J)
GOTO REDO
+1 SET X=^DD(J(N),DA,1,DICD,2)
if "Q"'[X
DO DD^DICD
SET DIU=^DIC(DIUF,0,"GL")
REDO SET X=^DD(J(N),DL,1,DICD,1)
if "Q"'[X
DO DD^DICD
WRITE $CHAR(7)," ...DONE!"
QUIT
+1 ;
Q FOR I=1:1:X
WRITE !,"FIELD "
SET %=X(I,0)
SET J=$PIECE(%,U,2)
WRITE J_" ('"_$PIECE(^DD(+%,J,0),U,1)_"'"
if %-DI
WRITE ", "_$ORDER(^DD(+%,0,"NM",0))_" SUBFILE"
WRITE ") IS ",$SELECT(X(I):"'"_$PIECE(X(I),U,2)_"' INDEX",1:$PIECE(X(I),U,3))
DO UP
+1 WRITE !!
DO LIST^DIKCUTL2(.DIUCNT,"INDEX FILE CROSS-REFERENCES:")
+2 GOTO 4
UP IF X(I)
IF X(I)-DI
SET %=$DATA(^DD(+X(I),0,"UP"))
WRITE " OF "_$ORDER(^("NM",0))_" "_$PIECE("SUB",U,%>0)_"FILE"
QUIT
+1 SET %=+$PIECE(X(I),U,4)
SET (%F,Y)=+$PIECE(X(I),U,5)
IF %
IF $DATA(^DD(%,Y,0))
if $X>44
WRITE !
WRITE " OF "
DO WR^DIDH
+2 QUIT
+3 ;
NO WRITE !?7,$CHAR(7),"<NO ACTION TAKEN>"
KILL DICD,X,DH
+1 QUIT
+2 ;
KWREG(ROOT,LEV,I,J) ;Kill entire regular index
+1 ;In:
+2 ; ROOT = open root of file or subfile
+3 ; LEV = level # of ROOT
+4 ; I = ^DD(file#,field#,1,xref#,0) [xref header node] = rfile#^name
+5 ; I(N) = node on which multiple at level n resides (for N>0)
+6 ; J(N) = level N subfile #
+7 ;
+8 NEW CROOT
+9 SET CROOT=$$CREF^DILF(ROOT)
+10 if '$DATA(@CROOT)
QUIT
+11 IF J(LEV)=+I
KILL @CROOT@($PIECE(I,U,2))
QUIT
+12 ;
+13 NEW DA
+14 SET DA=0
+15 FOR
SET DA=$ORDER(@CROOT@(DA))
if 'DA
QUIT
if $DATA(@CROOT@(DA,0))#2
DO KWREG(ROOT_DA_","_I(LEV+1)_",",LEV+1,.I,.J)
+16 QUIT
+17 ;
+18 ;==============
+19 ; ONEXR(file#)
+20 ;==============
+21 ;Prompt for file/subfile and Index; run kill/set logic for that Index
+22 ;In:
+23 ; DI = top level file #
+24 ;
ONEXR(DI) ;Re-index one cross reference
+1 ;Prompt for subfile
+2 NEW DIUCNT,DIUCTRL,DIUFILE,DIULOG,DIUXR
+3 WRITE !!?10,"File: "_$ORDER(^DD(DI,0,"NM",""))_" (#"_DI_")"
+4 SET DIUFILE=$$SUB^DIKCU(DI)
if DIUFILE=""
GOTO NO
+5 ;
+6 ;Prompt for xref
+7 DO GETXR^DIKCUTL2(DIUFILE,.DIUCNT,"x")
+8 WRITE !
DO LIST^DIKCUTL2(.DIUCNT)
+9 SET DIUXR=$$CHOOSE^DIKCUTL2(.DIUCNT,"re-cross-reference")
+10 if 'DIUXR
GOTO NO
+11 ;
+12 ;Run kill and/or set
+13 SET DIUCTRL=$$LOGIC($PIECE(DIUCNT(DIUXR),U,3))
+14 if DIUCTRL=""
GOTO NO
+15 ;
+16 if DI'=DIUFILE
SET DIUCTRL=DIUCTRL_"W"_DIUFILE
+17 DO INDEX^DIKC(DI,"","",DIUXR,DIUCTRL_"R")
+18 WRITE $CHAR(7)_" ...DONE!"
+19 QUIT
+20 ;
+21 ;====================
+22 ; $$LOGIC(indexName)
+23 ;====================
+24 ;Prompt for whether kill and/or set logic should be run.
+25 ;In:
+26 ; DIUNAME = name of xref (used in prompt)
+27 ;Return value:
+28 ; [ K : if kill logic should be run
+29 ; [ S : if set logic should be run
+30 ;
LOGIC(DIUNAME) ;
+1 NEW DIULOG,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIULOG=""
+3 ;
+4 ;Ask whether kill logic should be executed
+5 SET DIR(0)="Y"
+6 SET DIR("A")="Do you want to delete the existing '"_DIUNAME_"' cross-reference"
+7 SET DIR("?")=" Enter 'YES' if you want to run the kill logic for this cross-reference."
+8 WRITE !
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT ""
+9 if Y
SET DIULOG="K"
+10 ;
+11 ;Ask whether set logic should be executed
+12 SET DIR(0)="Y"
+13 SET DIR("A")="Do you want to re-build the '"_DIUNAME_"' cross reference"
+14 SET DIR("?")=" Enter 'YES' if you want to run the set logic for this cross reference."
+15 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT ""
+16 if Y
SET DIULOG=DIULOG_"S"
+17 QUIT DIULOG
