DICFIX ;SEA/TOAD,SF/TKW-FileMan: Finder, Search Compound Indexes ;5/26/99 14:40 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**4**;Mar 30, 1999;
;Per VHA Directive 10-93-142, this routine should not be modified.
;
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)
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"))
;
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="" Q
. 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
. 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
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) S DIDONE=1 Q
I $P(DIVAL,$G(DIPART))'="" S DIDONE=1 Q
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
;
;
DICFIX ;SEA/TOAD,SF/TKW-FileMan: Finder, Search Compound Indexes ;5/26/99 14:40 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**4**;Mar 30, 1999;
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
+4 ;
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 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 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 +2 IF DISUB'>DINDEX("#")
Begin DoDot:2
+3 SET DISKIP=0
+4 IF DIVAL'=""
IF '$DATA(DINDEX(DISUB,"IXROOT"))
DO CHK
IF DISKIP
QUIT
+5 IF DIVAL=""
SET DIDONE=1
+6 IF DIDONE
IF 'DITRXNO
QUIT
Begin DoDot:3
+7 SET DITRXNO=$ORDER(DINDEX(DISUB,DITRXNO))
IF 'DITRXNO
QUIT
+8 SET (DIVAL,DIPART)=DINDEX(DISUB,DITRXNO)
+9 IF DITRXNO=3!(DITRXNO=4)
IF DIDENT(-1)>DINDEX("TOTAL")
SET DISKIP=1
+10 SET DIDONE=0
+11 QUIT
End DoDot:3
IF DIDONE!(DISKIP)
QUIT
+12 SET DINDEX(DISUB)=DIVAL
SET DINDEX("AT")=DISUB+1
+13 SET DINDEX(DISUB,"FOUND")=DITRXNO
SET DIDENT(-4)=1
+14 IF DISUB=1
IF $DATA(DINDEX(1,"IXROOT"))
SET DINDEX(1)=$PIECE(DIVAL,U,2)
+15 DO WALK(.DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DIC,.DIY,.DIYX)
+16 SET DINDEX("AT")=DISUB
+17 SET DIDENT(-4)=DITRXNO
+18 IF DISUB=1
IF $DATA(DINDEX(1,"IXROOT"))
SET DINDEX(1)=DIVAL
+19 IF $GET(DINDEX("DONE"))!$GET(DIERR)
SET DIDONE=1
End DoDot:2
QUIT
+20 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 SET DIMNEM=""
QUIT
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 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 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 IF DIFLAGS["X"
IF DIVAL'=DINDEX(DISUB,DITRXNO)
SET DIDONE=1
QUIT
+3 IF $PIECE(DIVAL,$GET(DIPART))'=""
SET DIDONE=1
QUIT
+4 IF $GET(DINDEX(DISUB,+DITRXNO,"c"))]""
Begin DoDot:1
+5 DO NXTNAM^DICFIX1(.DIVAL,DIPART,.DINDEX,.DISKIP,.DIDONE)
QUIT
End DoDot:1
IF DIDONE!(DISKIP)
QUIT
+6 QUIT
+7 ;
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 ;
