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
