- DIK1 ;SFISC/GFT-ACTUAL INDEXER ;7SEP2011
- ;;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.
- ;
- EN N DIC D DI
- D
- . N DIKSV S DIKSV=DIK N DIK,DIKJ,DIFKEP
- . D INDEX^DIKC(DIKSV,.DA,"","","KT")
- D K G Q:'$D(@(DIK_"0)")) ;IF ZERO NODE IS THERE, RE-SET IT
- S Y=^(0),DH=$S($O(^(0))'>0:0,1:$P(Y,U,4)-1),X=$P($P(Y,U,3),U,DH>0) D 3:X=DA
- S ^(0)=$P(Y,U,1,2)_U_X_U_DH
- IDENTF I DIK?1"^DD(".NP1",",$G(DA(1)),DIK[DA(1) K ^DD(DA(1),0,"ID",DA),^("W"_DA)
- Q K:$G(DIKJ) ^UTILITY("DIK",DIKJ)
- K DB(0),DIKJ,DIKS,DIN,DH,DU,DV,DW,DIKGP Q
- ;
- K S X="",Y=1 I $D(DIFKEP(DA))#2,DIK="^DIC(",$D(@(DIK_DA_",0,""GL"")")) S X=^("GL"),Y="^DIC("_DA_","
- I X'=Y K @(DIK_"DA)"),X,Y Q
- S X=DIK_"DA,",DH=@(X_"0)") K ^(0),^("%") S Y="""%""" F S Y=$O(@(X_Y_")")) Q:$E(Y)'="%" S Y=""""_Y_"""" K @(X_Y_")")
- S @(X_"0)")=DH K X,Y
- Q
- ;
- 3 N X1
- S X1=X,X=+$O(^(X1),-1)
- S:X'>0 X=+$O(^(X1))
- Q
- ;
- DI S (DIC,DIN)=DIK,DH=DH(DU),DV=1 F S DV=$O(DA(DV)) Q:DV'>0 S DU=DU+1
- DIN S DV=0 F S DV=$O(^UTILITY("DIK",DIKJ,DH,DV)) Q:DV="" D R:$G(DIKSET)!(DV-.01)
- DVA S DV=$O(DV(DH,DV)) I DV="" Q:$G(DIKSET) S DV=.01 D R:$D(^UTILITY("DIK",DIKJ,DH,DV)) Q
- S X=DIN_DA_","_DV(DH,DV) I @("'$D("_X_"))") G DVA
- S DU(DU)=DIN,DIN=X_",",DH(DU)=DH,DH=DV(DH,DV,0),DV(DU)=DV,DU=DU+1 F X=DU:-1:1 I $D(DA(X)) S DA(X+1)=DA(X)
- S DA(1)=DA,DA=0
- DA I '$D(DV(DH(DU-1),DV,"NOLOOP")) F S @("DA=$O("_DIN_"DA))") Q:DA'>0 D DIN
- D:$D(^UTILITY("DIK",DIKJ,"KW",DH)) KW(DH,DIN)
- S DU=DU-1,DIN=DU(DU),DH=DH(DU),DV=DV(DU),DA=DA(1) K DA(1) F X=2:1 G DVA:'$D(DA(X)) S DA(X-1)=DA(X) K DA(X)
- ;EXECUTE CROSS-REFERENCES
- R S X=^UTILITY("DIK",DIKJ,DH,DV),%=^(DV,0) I @("$D("_DIN_DA_",X))[0") Q
- X % Q:X']"" S DIKS=X,DW=0
- XEC S DW=$O(^UTILITY("DIK",DIKJ,DH,DV,DW)) Q:DW="" D NXEC(^(DW)) S X=DIKS G XEC
- ;
- NXEC(DICODE) ;New variables and execute programming hook
- I DICODE="D RCR"
- E I $G(DW)=99,DICODE?.E1" AUDIT"
- E N DH,DIFKEP,DIK,DIKJ,DIKS,DIKSET,DIN,DU,DV,DW,KW
- X DICODE
- Q
- RCR K Y,%RCR F %="DIKS","DIK","DW","DH","DIN","DU","DV","X","KW","DIKSET" S %RCR(%)=""
- S %RCR="RR^DIK1",Y=^UTILITY("DIK",DIKJ,DH,DV,DW,0) G STORLIST^%RCR
- ;
- RR X Y Q
- ;
- AUDIT N %,%F,%T,%D,DIKF,DIKDA Q:DIIX=3&($D(DIKNM)!$D(DIKKS)) S %=DV N DV S DV=%
- S %F=DH F %=1:1 Q:'$D(^DD(%F,0,"UP")) S %D=%F,%F=^("UP"),DV(%)=$O(^DD(%F,"SB",%D,0)) S:DV(%)="" DV(%)=-1
- S DIKDA="",DIKF="" F %=%-1:-1:1 S DIKDA=DIKDA_DA(%)_",",DIKF=DIKF_DV(%)_","
- I $G(^DD(DH,DV,"AX"))]"" D NXEC(^("AX")) I '$T Q
- D ADD^DIET S DIAU(DH,DV,DIKDA_DA)="^DIA("_%F_","_+Y_",",^DIA(%F,%D,0)=DIKDA_DA_U_%T_U_DIKF_DV_U_DUZ,^DIA(%F,"B",DIKDA_DA,%D)=""
- SET N C S (%F,C)=$P(^DD(DH,DV,0),U,2),Y=X D:Y]"" S^DIQ S @(DIAU(DH,DV,DIKDA_DA)_"DIIX)")=Y S:DIIX=2&($D(DIKNM)!$D(DIKKS)) ^(3)=Y
- K DIAU I %F["P"!(%F["V")!(%F["S") S ^(DIIX+.1)=X_U_%F
- Q
- ;
- 1 ;
- N DIKLK
- S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK D DI L:$D(DIKLK) -@DIKLK G Q
- ;
- CNT ;
- N DIKLK,DIKLAST S DIKLAST=$S(DA:DA,1:"")
- S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU) L +@DIKLK:10 K:'$T DIKLK
- C I @("$O("_DIK_"DA))'>0") S $P(@(DIK_"0)"),U,4)=DCNT D:'$P(^(0),U,3) D:$D(^UTILITY("DIK",DIKJ,"KW",DH(1))) KW(DH(1),DIK) K DCNT L:$D(DIKLK) -@DIKLK G Q ;**DI*22*146
- .S DCNT=$O(^(" "),-1) I DCNT S $P(^(0),U,3)=DCNT
- S DA=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DIKLAST=DA,DU=1,DCNT=DCNT+1 S:DA="" DA=-1 D:(DCNT#100=0) D DI K DB(0) G C
- .I $D(IO)#2,$D(IO(0))#2,IO=IO(0),IO="" Q
- .I '$D(ZTQUEUED) W "."
- ;
- KW(FIL,DIN) ;Kill entire regular indexes
- N NAM
- S NAM="" F S NAM=$O(^UTILITY("DIK",DIKJ,"KW",FIL,NAM)) Q:NAM="" K @(DIN_""""_NAM_""")")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIK1 3793 printed Jan 18, 2025@03:49:37 Page 2
- DIK1 ;SFISC/GFT-ACTUAL INDEXER ;7SEP2011
- +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 ;
- EN NEW DIC
- DO DI
- +1 Begin DoDot:1
- +2 NEW DIKSV
- SET DIKSV=DIK
- NEW DIK,DIKJ,DIFKEP
- +3 DO INDEX^DIKC(DIKSV,.DA,"","","KT")
- End DoDot:1
- +4 ;IF ZERO NODE IS THERE, RE-SET IT
- DO K
- if '$DATA(@(DIK_"0)"))
- GOTO Q
- +5 SET Y=^(0)
- SET DH=$SELECT($ORDER(^(0))'>0:0,1:$PIECE(Y,U,4)-1)
- SET X=$PIECE($PIECE(Y,U,3),U,DH>0)
- if X=DA
- DO 3
- +6 SET ^(0)=$PIECE(Y,U,1,2)_U_X_U_DH
- IDENTF IF DIK?1"^DD(".NP1","
- IF $GET(DA(1))
- IF DIK[DA(1)
- KILL ^DD(DA(1),0,"ID",DA),^("W"_DA)
- Q if $GET(DIKJ)
- KILL ^UTILITY("DIK",DIKJ)
- +1 KILL DB(0),DIKJ,DIKS,DIN,DH,DU,DV,DW,DIKGP
- QUIT
- +2 ;
- K SET X=""
- SET Y=1
- IF $DATA(DIFKEP(DA))#2
- IF DIK="^DIC("
- IF $DATA(@(DIK_DA_",0,""GL"")"))
- SET X=^("GL")
- SET Y="^DIC("_DA_","
- +1 IF X'=Y
- KILL @(DIK_"DA)"),X,Y
- QUIT
- +2 SET X=DIK_"DA,"
- SET DH=@(X_"0)")
- KILL ^(0),^("%")
- SET Y="""%"""
- FOR
- SET Y=$ORDER(@(X_Y_")"))
- if $EXTRACT(Y)'="%"
- QUIT
- SET Y=""""_Y_""""
- KILL @(X_Y_")")
- +3 SET @(X_"0)")=DH
- KILL X,Y
- +4 QUIT
- +5 ;
- 3 NEW X1
- +1 SET X1=X
- SET X=+$ORDER(^(X1),-1)
- +2 if X'>0
- SET X=+$ORDER(^(X1))
- +3 QUIT
- +4 ;
- DI SET (DIC,DIN)=DIK
- SET DH=DH(DU)
- SET DV=1
- FOR
- SET DV=$ORDER(DA(DV))
- if DV'>0
- QUIT
- SET DU=DU+1
- DIN SET DV=0
- FOR
- SET DV=$ORDER(^UTILITY("DIK",DIKJ,DH,DV))
- if DV=""
- QUIT
- if $GET(DIKSET)!(DV-.01)
- DO R
- DVA SET DV=$ORDER(DV(DH,DV))
- IF DV=""
- if $GET(DIKSET)
- QUIT
- SET DV=.01
- if $DATA(^UTILITY("DIK",DIKJ,DH,DV))
- DO R
- QUIT
- +1 SET X=DIN_DA_","_DV(DH,DV)
- IF @("'$D("_X_"))")
- GOTO DVA
- +2 SET DU(DU)=DIN
- SET DIN=X_","
- SET DH(DU)=DH
- SET DH=DV(DH,DV,0)
- SET DV(DU)=DV
- SET DU=DU+1
- FOR X=DU:-1:1
- IF $DATA(DA(X))
- SET DA(X+1)=DA(X)
- +3 SET DA(1)=DA
- SET DA=0
- DA IF '$DATA(DV(DH(DU-1),DV,"NOLOOP"))
- FOR
- SET @("DA=$O("_DIN_"DA))")
- if DA'>0
- QUIT
- DO DIN
- +1 if $DATA(^UTILITY("DIK",DIKJ,"KW",DH))
- DO KW(DH,DIN)
- +2 SET DU=DU-1
- SET DIN=DU(DU)
- SET DH=DH(DU)
- SET DV=DV(DU)
- SET DA=DA(1)
- KILL DA(1)
- FOR X=2:1
- if '$DATA(DA(X))
- GOTO DVA
- SET DA(X-1)=DA(X)
- KILL DA(X)
- +3 ;EXECUTE CROSS-REFERENCES
- R SET X=^UTILITY("DIK",DIKJ,DH,DV)
- SET %=^(DV,0)
- IF @("$D("_DIN_DA_",X))[0")
- QUIT
- +1 XECUTE %
- if X']""
- QUIT
- SET DIKS=X
- SET DW=0
- XEC SET DW=$ORDER(^UTILITY("DIK",DIKJ,DH,DV,DW))
- if DW=""
- QUIT
- DO NXEC(^(DW))
- SET X=DIKS
- GOTO XEC
- +1 ;
- NXEC(DICODE) ;New variables and execute programming hook
- +1 IF DICODE="D RCR"
- +2 IF '$TEST
- IF $GET(DW)=99
- IF DICODE?.E1" AUDIT"
- +3 IF '$TEST
- NEW DH,DIFKEP,DIK,DIKJ,DIKS,DIKSET,DIN,DU,DV,DW,KW
- +4 XECUTE DICODE
- +5 QUIT
- RCR KILL Y,%RCR
- FOR %="DIKS","DIK","DW","DH","DIN","DU","DV","X","KW","DIKSET"
- SET %RCR(%)=""
- +1 SET %RCR="RR^DIK1"
- SET Y=^UTILITY("DIK",DIKJ,DH,DV,DW,0)
- GOTO STORLIST^%RCR
- +2 ;
- RR XECUTE Y
- QUIT
- +1 ;
- AUDIT NEW %,%F,%T,%D,DIKF,DIKDA
- if DIIX=3&($DATA(DIKNM)!$DATA(DIKKS))
- QUIT
- SET %=DV
- NEW DV
- SET DV=%
- +1 SET %F=DH
- FOR %=1:1
- if '$DATA(^DD(%F,0,"UP"))
- QUIT
- SET %D=%F
- SET %F=^("UP")
- SET DV(%)=$ORDER(^DD(%F,"SB",%D,0))
- if DV(%)=""
- SET DV(%)=-1
- +2 SET DIKDA=""
- SET DIKF=""
- FOR %=%-1:-1:1
- SET DIKDA=DIKDA_DA(%)_","
- SET DIKF=DIKF_DV(%)_","
- +3 IF $GET(^DD(DH,DV,"AX"))]""
- DO NXEC(^("AX"))
- IF '$TEST
- QUIT
- +4 DO ADD^DIET
- SET DIAU(DH,DV,DIKDA_DA)="^DIA("_%F_","_+Y_","
- SET ^DIA(%F,%D,0)=DIKDA_DA_U_%T_U_DIKF_DV_U_DUZ
- SET ^DIA(%F,"B",DIKDA_DA,%D)=""
- SET NEW C
- SET (%F,C)=$PIECE(^DD(DH,DV,0),U,2)
- SET Y=X
- if Y]""
- DO S^DIQ
- SET @(DIAU(DH,DV,DIKDA_DA)_"DIIX)")=Y
- if DIIX=2&($DATA(DIKNM)!$DATA(DIKKS))
- SET ^(3)=Y
- +1 KILL DIAU
- IF %F["P"!(%F["V")!(%F["S")
- SET ^(DIIX+.1)=X_U_%F
- +2 QUIT
- +3 ;
- 1 ;
- +1 NEW DIKLK
- +2 SET DIKLK=DIK_DA_")"
- LOCK +@DIKLK:10
- if '$TEST
- KILL DIKLK
- DO DI
- if $DATA(DIKLK)
- LOCK -@DIKLK
- GOTO Q
- +3 ;
- CNT ;
- +1 NEW DIKLK,DIKLAST
- SET DIKLAST=$SELECT(DA:DA,1:"")
- +2 SET DU=$EXTRACT(DIK,1,$LENGTH(DIK)-1)
- SET DIKLK=$SELECT(DIK[",":DU_")",1:DU)
- LOCK +@DIKLK:10
- if '$TEST
- KILL DIKLK
- C ;**DI*22*146
- IF @("$O("_DIK_"DA))'>0")
- SET $PIECE(@(DIK_"0)"),U,4)=DCNT
- if '$PIECE(^(0),U,3)
- Begin DoDot:1
- +1 SET DCNT=$ORDER(^(" "),-1)
- IF DCNT
- SET $PIECE(^(0),U,3)=DCNT
- End DoDot:1
- if $DATA(^UTILITY("DIK",DIKJ,"KW",DH(1)))
- DO KW(DH(1),DIK)
- KILL DCNT
- if $DATA(DIKLK)
- LOCK -@DIKLK
- GOTO Q
- +2 SET DA=$ORDER(^(DA))
- if $PIECE($GET(^(DA,0)),U)']""
- GOTO C
- SET DIKLAST=DA
- SET DU=1
- SET DCNT=DCNT+1
- if DA=""
- SET DA=-1
- if (DCNT#100=0)
- Begin DoDot:1
- +3 IF $DATA(IO)#2
- IF $DATA(IO(0))#2
- IF IO=IO(0)
- IF IO=""
- QUIT
- +4 IF '$DATA(ZTQUEUED)
- WRITE "."
- End DoDot:1
- DO DI
- KILL DB(0)
- GOTO C
- +5 ;
- KW(FIL,DIN) ;Kill entire regular indexes
- +1 NEW NAM
- +2 SET NAM=""
- FOR
- SET NAM=$ORDER(^UTILITY("DIK",DIKJ,"KW",FIL,NAM))
- if NAM=""
- QUIT
- KILL @(DIN_""""_NAM_""")")
- +3 QUIT