DICFIX ;SEA/TOAD,SF/TKW-FileMan: Finder, Search Compound Indexes ;5SEP2014
;;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.
;
;
WALK(DIFLAGS,DINDEX,DIDENT,DIFILE,DIEN,DIFIEN,DISCREEN,DILIST,DIC,DIY,DIYX) ;
;
; a walker to traverse a compound index, taking actions
; DINDEX is an array describing the index and how to walk it
;
PREP ; prepare to loop through subscript
;
N DISUB S DISUB=DINDEX("AT")
N DIVAL S DIVAL=DINDEX(DISUB) ;THE TRUNCATED VERSION OF A LONG NAME
N DIPART,DIMORE S DIPART=$G(DINDEX(DISUB,"PART")),DIMORE=+$G(DINDEX(DISUB,"MORE?"))
N DITRXNO S DITRXNO=DIDENT(-4)
I $G(DINDEX(DISUB,"USE")),DIVAL'="" D
. S DIVAL=$O(@DINDEX(DISUB,"ROOT")@(DIVAL),-DINDEX(DISUB,"WAY")) ;BACK UP TO THE PREVIOUS SUBSCRIPT
;
LOOP ; loop through subscripts
;
N DIDONE,DISKIP S DIDONE=0 F D Q:DIDONE!$G(DIERR)
. S DIVAL=$O(@DINDEX(DISUB,"ROOT")@(DIVAL),DINDEX(DISUB,"WAY"))
.
DATA . ; if we're in the data subscripts, we need to walk further
. I DISUB'>DINDEX("#") D Q
. . S DISKIP=0
. . I DIVAL'="",'$D(DINDEX(DISUB,"IXROOT")) D CHK Q:DISKIP
. . S:DIVAL="" DIDONE=1
. . I DIDONE Q:'DITRXNO D Q:DIDONE!(DISKIP)
. . . S DITRXNO=$O(DINDEX(DISUB,DITRXNO)) Q:'DITRXNO
. . . S (DIVAL,DIPART)=DINDEX(DISUB,DITRXNO)
. . . I DITRXNO=3!(DITRXNO=4),DIDENT(-1)>DINDEX("TOTAL") S DISKIP=1
. . . S DIDONE=0
. . . Q
. . S DINDEX(DISUB)=DIVAL,DINDEX("AT")=DISUB+1
. . S DINDEX(DISUB,"FOUND")=DITRXNO,DIDENT(-4)=1
. . I DISUB=1,$D(DINDEX(1,"IXROOT")) S DINDEX(1)=$P(DIVAL,U,2)
. . D WALK(.DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DIC,.DIY,.DIYX)
. . S DINDEX("AT")=DISUB
. . S DIDENT(-4)=DITRXNO
. . I DISUB=1,$D(DINDEX(1,"IXROOT")) S DINDEX(1)=DIVAL
. . I $G(DINDEX("DONE"))!$G(DIERR) S DIDONE=1
.
IEN . ; otherwise, we're in the IEN subscripts & need to process
.
. I DIVAL="" S DIDONE=1 Q
. I DINDEX="B" N DIMNEM D
. . I $D(@DINDEX(DISUB,"ROOT")@(DIVAL))#2 Q:'^(DIVAL)
. . E Q:'$O(@DINDEX(DISUB,"ROOT")@(DIVAL,""))
. . S DIMNEM="" ;WE HAVE FOUND A MNEMONIC. DOES THIS VARIABLE AFFECT T1+14^DICU11?
. D TRY
. Q
CLEAN ; clean up after loop, exit
S DINDEX(DISUB)=$S(DISUB<(DINDEX("#")+1):$G(DINDEX(DISUB,"FROM")),1:"")
S DIDENT(-4)=1
Q
;
CHK ; See whether we have a match or are at the end of the subscripts.
I DISUB>1,"VP"[DINDEX(DISUB,"TYPE"),DIFLAGS'["Q" D Q ;variable-pointer
. N DIFL,DIFLD,DIV
. S DIFL=DINDEX(DISUB,"FILE"),DIFLD=DINDEX(DISUB,"FIELD"),DIV=DIVAL
. I DINDEX(DISUB,"TYPE")="V",$G(DISCREEN("V",DISUB))]"" D Q:DISKIP
. . N G S G="^"_$P(DIV,";",2) Q:G="^"
. . S:'$D(DINDEX(DISUB,"VP",G)) DISKIP=1 Q
. N DIVAL S DIVAL=$$EXTERNAL^DIDU(DIFL,DIFLD,"i",DIV)
. I $G(DIERR),DIFLAGS["l" K DIERR,^TMP("DIERR",$J) S DIVAL=DIV
. I DIVAL="" S DIDONE=1 Q
. F DITRXNO=0:0 S DITRXNO=$O(DINDEX(DISUB,DITRXNO)) Q:'DITRXNO D Q:'DIDONE
. . S DIPART=DINDEX(DISUB,DITRXNO),DIDONE=0
. . D MATCH I DIDONE,'$G(DINDEX("DONE")),DIMORE,DIFLAGS'["X" D
. . . S DIDONE=0 D FINDMORE^DICLIX0(DISUB,.DIVAL,DIPART,.DINDEX,.DIMORE) I DIVAL="" S DIDONE=1 Q
. . . D MATCH Q
. . Q:DIDONE
. . S DINDEX(DISUB,"EXT")=$$EXTERNAL^DIDU(DIFL,DIFLD,"",DIV)
. . I $G(DIERR),DIFLAGS["l" K DIERR,^TMP("DIERR",$J) S DINDEX(DISUB,"EXT")=DIV
. . Q
. I DIDONE S DIDONE=0,DISKIP=1
. Q
D MATCH I DIDONE,'$G(DINDEX("DONE")),DIMORE,DIFLAGS'["X" D
. S DIDONE=0 D FINDMORE^DICLIX0(DISUB,.DIVAL,DIPART,.DINDEX,.DIMORE) I DIVAL="" S DIDONE=1 Q
. D MATCH Q ;Pretty redundant!!
Q
;
MATCH ; No more subscripts or partial matches, or past our TO value?
Q:DIVAL="" I DIFLAGS["l",DINDEX(DISUB,DITRXNO)="" Q
I DIFLAGS["X",DIVAL'=DINDEX(DISUB,DITRXNO),DIVAL'=$G(DINDEX(DISUB,0,DITRXNO)) S DIDONE=1 Q ;FOR FILE 101, DIVAL IS THE LONG NAME, DINDEX(1,1) IS THE TRUNCATED VERSION, BUT DINDEX(1,0,1) IS LONG
I $P(DIVAL,$G(DIPART))'="" S DIDONE=1 Q
NUM ;I +$P($G(DIPART),"E")=$G(DIPART),+$P(DIVAL,"E")=DIVAL,DIVAL'=DIPART S DIDONE=1 Q ;***'100' SHOULD NOT MATCH '1000' -- MCPHELAN. BUT VA DISAGREES.
I $G(DINDEX(DISUB,+DITRXNO,"c"))]"" D Q:DIDONE!(DISKIP)
. D NXTNAM^DICFIX1(.DIVAL,DIPART,.DINDEX,.DISKIP,.DIDONE) Q
Q
;
TRY ; Apply screens to entry. If passed, add entry to output.
S (DIEN,DINDEX(DISUB))=DIVAL
N DI0NODE S DI0NODE=$G(@DIFILE(DIFILE)@(DIEN,0))
Q:$$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE)
; If called from ^DIC, special processing.
I DIFLAGS["l" D DICLIST Q
; Else, add entry to output list.
D ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE)
Q:$G(DIERR)
I DIDENT(-1)=DIDENT(-1,"MAX"),'DIDENT(-1,"JUST LOOKING") S DIDONE=1,DINDEX("DONE")=1
Q
;
DICLIST ; Build output list when Finder is called from ^DIC.
; Display entries and allow selection if screen is filled.
K DTOUT,DUOUT N D,DIX,DIFINDR,DIFILE,X,Y I DIC(0)["E" N DIQUIET
S Y=DIEN,D=DINDEX,DIX=DINDEX(1),DIFINDR=1
S X=$S("VP"[DINDEX(1,"TYPE"):DIX,1:DINDEX(1,DINDEX(1,"FOUND")))
I "VP"[DINDEX(1,"TYPE") S DS(0,"DICRS")=1
I "D"[DINDEX(1,"TYPE") S DS(0,"DIDA")=1
D MN^DIC3 Q:'$T
D K^DIC3
I DS(0) S (DIDONE,DINDEX("DONE"))=1
Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICFIX 5393 printed Sep 23, 2025@20:22:12 Page 2
DICFIX ;SEA/TOAD,SF/TKW-FileMan: Finder, Search Compound Indexes ;5SEP2014
+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 ;
WALK(DIFLAGS,DINDEX,DIDENT,DIFILE,DIEN,DIFIEN,DISCREEN,DILIST,DIC,DIY,DIYX) ;
+1 ;
+2 ; a walker to traverse a compound index, taking actions
+3 ; DINDEX is an array describing the index and how to walk it
+4 ;
PREP ; prepare to loop through subscript
+1 ;
+2 NEW DISUB
SET DISUB=DINDEX("AT")
+3 ;THE TRUNCATED VERSION OF A LONG NAME
NEW DIVAL
SET DIVAL=DINDEX(DISUB)
+4 NEW DIPART,DIMORE
SET DIPART=$GET(DINDEX(DISUB,"PART"))
SET DIMORE=+$GET(DINDEX(DISUB,"MORE?"))
+5 NEW DITRXNO
SET DITRXNO=DIDENT(-4)
+6 IF $GET(DINDEX(DISUB,"USE"))
IF DIVAL'=""
Begin DoDot:1
+7 ;BACK UP TO THE PREVIOUS SUBSCRIPT
SET DIVAL=$ORDER(@DINDEX(DISUB,"ROOT")@(DIVAL),-DINDEX(DISUB,"WAY"))
End DoDot:1
+8 ;
LOOP ; loop through subscripts
+1 ;
+2 NEW DIDONE,DISKIP
SET DIDONE=0
FOR
Begin DoDot:1
+3 SET DIVAL=$ORDER(@DINDEX(DISUB,"ROOT")@(DIVAL),DINDEX(DISUB,"WAY"))
+4 DATA ; if we're in the data subscripts, we need to walk further
+1 IF DISUB'>DINDEX("#")
Begin DoDot:2
+2 SET DISKIP=0
+3 IF DIVAL'=""
IF '$DATA(DINDEX(DISUB,"IXROOT"))
DO CHK
if DISKIP
QUIT
+4 if DIVAL=""
SET DIDONE=1
+5 IF DIDONE
if 'DITRXNO
QUIT
Begin DoDot:3
+6 SET DITRXNO=$ORDER(DINDEX(DISUB,DITRXNO))
if 'DITRXNO
QUIT
+7 SET (DIVAL,DIPART)=DINDEX(DISUB,DITRXNO)
+8 IF DITRXNO=3!(DITRXNO=4)
IF DIDENT(-1)>DINDEX("TOTAL")
SET DISKIP=1
+9 SET DIDONE=0
+10 QUIT
End DoDot:3
if DIDONE!(DISKIP)
QUIT
+11 SET DINDEX(DISUB)=DIVAL
SET DINDEX("AT")=DISUB+1
+12 SET DINDEX(DISUB,"FOUND")=DITRXNO
SET DIDENT(-4)=1
+13 IF DISUB=1
IF $DATA(DINDEX(1,"IXROOT"))
SET DINDEX(1)=$PIECE(DIVAL,U,2)
+14 DO WALK(.DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DIC,.DIY,.DIYX)
+15 SET DINDEX("AT")=DISUB
+16 SET DIDENT(-4)=DITRXNO
+17 IF DISUB=1
IF $DATA(DINDEX(1,"IXROOT"))
SET DINDEX(1)=DIVAL
+18 IF $GET(DINDEX("DONE"))!$GET(DIERR)
SET DIDONE=1
End DoDot:2
QUIT
+19 IEN ; otherwise, we're in the IEN subscripts & need to process
+1 +2 IF DIVAL=""
SET DIDONE=1
QUIT
+3 IF DINDEX="B"
NEW DIMNEM
Begin DoDot:2
+4 IF $DATA(@DINDEX(DISUB,"ROOT")@(DIVAL))#2
if '^(DIVAL)
QUIT
+5 IF '$TEST
if '$ORDER(@DINDEX(DISUB,"ROOT")@(DIVAL,""))
QUIT
+6 ;WE HAVE FOUND A MNEMONIC. DOES THIS VARIABLE AFFECT T1+14^DICU11?
SET DIMNEM=""
End DoDot:2
+7 DO TRY
+8 QUIT
End DoDot:1
if DIDONE!$GET(DIERR)
QUIT
CLEAN ; clean up after loop, exit
+1 SET DINDEX(DISUB)=$SELECT(DISUB<(DINDEX("#")+1):$GET(DINDEX(DISUB,"FROM")),1:"")
+2 SET DIDENT(-4)=1
+3 QUIT
+4 ;
CHK ; See whether we have a match or are at the end of the subscripts.
+1 ;variable-pointer
IF DISUB>1
IF "VP"[DINDEX(DISUB,"TYPE")
IF DIFLAGS'["Q"
Begin DoDot:1
+2 NEW DIFL,DIFLD,DIV
+3 SET DIFL=DINDEX(DISUB,"FILE")
SET DIFLD=DINDEX(DISUB,"FIELD")
SET DIV=DIVAL
+4 IF DINDEX(DISUB,"TYPE")="V"
IF $GET(DISCREEN("V",DISUB))]""
Begin DoDot:2
+5 NEW G
SET G="^"_$PIECE(DIV,";",2)
if G="^"
QUIT
+6 if '$DATA(DINDEX(DISUB,"VP",G))
SET DISKIP=1
QUIT
End DoDot:2
if DISKIP
QUIT
+7 NEW DIVAL
SET DIVAL=$$EXTERNAL^DIDU(DIFL,DIFLD,"i",DIV)
+8 IF $GET(DIERR)
IF DIFLAGS["l"
KILL DIERR,^TMP("DIERR",$JOB)
SET DIVAL=DIV
+9 IF DIVAL=""
SET DIDONE=1
QUIT
+10 FOR DITRXNO=0:0
SET DITRXNO=$ORDER(DINDEX(DISUB,DITRXNO))
if 'DITRXNO
QUIT
Begin DoDot:2
+11 SET DIPART=DINDEX(DISUB,DITRXNO)
SET DIDONE=0
+12 DO MATCH
IF DIDONE
IF '$GET(DINDEX("DONE"))
IF DIMORE
IF DIFLAGS'["X"
Begin DoDot:3
+13 SET DIDONE=0
DO FINDMORE^DICLIX0(DISUB,.DIVAL,DIPART,.DINDEX,.DIMORE)
IF DIVAL=""
SET DIDONE=1
QUIT
+14 DO MATCH
QUIT
End DoDot:3
+15 if DIDONE
QUIT
+16 SET DINDEX(DISUB,"EXT")=$$EXTERNAL^DIDU(DIFL,DIFLD,"",DIV)
+17 IF $GET(DIERR)
IF DIFLAGS["l"
KILL DIERR,^TMP("DIERR",$JOB)
SET DINDEX(DISUB,"EXT")=DIV
+18 QUIT
End DoDot:2
if 'DIDONE
QUIT
+19 IF DIDONE
SET DIDONE=0
SET DISKIP=1
+20 QUIT
End DoDot:1
QUIT
+21 DO MATCH
IF DIDONE
IF '$GET(DINDEX("DONE"))
IF DIMORE
IF DIFLAGS'["X"
Begin DoDot:1
+22 SET DIDONE=0
DO FINDMORE^DICLIX0(DISUB,.DIVAL,DIPART,.DINDEX,.DIMORE)
IF DIVAL=""
SET DIDONE=1
QUIT
+23 ;Pretty redundant!!
DO MATCH
QUIT
End DoDot:1
+24 QUIT
+25 ;
MATCH ; No more subscripts or partial matches, or past our TO value?
+1 if DIVAL=""
QUIT
IF DIFLAGS["l"
IF DINDEX(DISUB,DITRXNO)=""
QUIT
+2 ;FOR FILE 101, DIVAL IS THE LONG NAME, DINDEX(1,1) IS THE TRUNCATED VERSION, BUT DINDEX(1,0,1) IS LONG
IF DIFLAGS["X"
IF DIVAL'=DINDEX(DISUB,DITRXNO)
IF DIVAL'=$GET(DINDEX(DISUB,0,DITRXNO))
SET DIDONE=1
QUIT
+3 IF $PIECE(DIVAL,$GET(DIPART))'=""
SET DIDONE=1
QUIT
NUM ;I +$P($G(DIPART),"E")=$G(DIPART),+$P(DIVAL,"E")=DIVAL,DIVAL'=DIPART S DIDONE=1 Q ;***'100' SHOULD NOT MATCH '1000' -- MCPHELAN. BUT VA DISAGREES.
+1 IF $GET(DINDEX(DISUB,+DITRXNO,"c"))]""
Begin DoDot:1
+2 DO NXTNAM^DICFIX1(.DIVAL,DIPART,.DINDEX,.DISKIP,.DIDONE)
QUIT
End DoDot:1
if DIDONE!(DISKIP)
QUIT
+3 QUIT
+4 ;
TRY ; Apply screens to entry. If passed, add entry to output.
+1 SET (DIEN,DINDEX(DISUB))=DIVAL
+2 NEW DI0NODE
SET DI0NODE=$GET(@DIFILE(DIFILE)@(DIEN,0))
+3 if $$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE)
QUIT
+4 ; If called from ^DIC, special processing.
+5 IF DIFLAGS["l"
DO DICLIST
QUIT
+6 ; Else, add entry to output list.
+7 DO ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE)
+8 if $GET(DIERR)
QUIT
+9 IF DIDENT(-1)=DIDENT(-1,"MAX")
IF 'DIDENT(-1,"JUST LOOKING")
SET DIDONE=1
SET DINDEX("DONE")=1
+10 QUIT
+11 ;
DICLIST ; Build output list when Finder is called from ^DIC.
+1 ; Display entries and allow selection if screen is filled.
+2 KILL DTOUT,DUOUT
NEW D,DIX,DIFINDR,DIFILE,X,Y
IF DIC(0)["E"
NEW DIQUIET
+3 SET Y=DIEN
SET D=DINDEX
SET DIX=DINDEX(1)
SET DIFINDR=1
+4 SET X=$SELECT("VP"[DINDEX(1,"TYPE"):DIX,1:DINDEX(1,DINDEX(1,"FOUND")))
+5 IF "VP"[DINDEX(1,"TYPE")
SET DS(0,"DICRS")=1
+6 IF "D"[DINDEX(1,"TYPE")
SET DS(0,"DIDA")=1
+7 DO MN^DIC3
if '$TEST
QUIT
+8 DO K^DIC3
+9 IF DS(0)
SET (DIDONE,DINDEX("DONE"))=1
+10 QUIT
+11 ;
+12 ;
