- 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 Jan 18, 2025@03:55:32 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