DICLIX ;SEA/TOAD,SF/TKW-FileMan: Lister, Search Compound Indexes ;6/5/00 10:13
;;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,DINDEX0,DIXV,DIC) ;
;
; 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?"))
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
. . I DISUB=1,$O(DIXV(0)) D LOWSUB
. . S DISKIP=0
. . I DIVAL'="",'$D(DINDEX(DISUB,"IXROOT")) D CHK Q:DISKIP
. . S:DIVAL="" DIDONE=1
. . Q:DIDONE
. . S DINDEX(DISUB)=DIVAL,DINDEX("AT")=DISUB+1
. . I $D(DINDEX("ROOTCNG",DISUB+1)) D BLDTMP^DICLIX1(.DINDEX,.DISCREEN,DIFLAGS,.DIDENT)
. . D WALK(.DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DINDEX0,"",.DIC)
. . S DINDEX("AT")=DISUB
. . I $G(DINDEX("DONE"))!$G(DIERR) S DIDONE=1
. . Q
.
IEN . ; otherwise, we're in the IEN subscripts & need to process
.
. I DIVAL="" S DIDONE=1 Q
. I DINDEX="B" N DISKIPMN,DIMNEM S DISKIPMN=0 D Q:DISKIPMN
. . I $D(@DINDEX(DISUB,"ROOT")@(DIVAL))#2 Q:'^(DIVAL)
. . E Q:'$O(@DINDEX(DISUB,"ROOT")@(DIVAL,""))
. . I DIFLAGS["M" S DISKIPMN=1 Q
. . S DIMNEM="" Q
. I $G(DINDEX(DISUB,"TO")) D Q:DIDONE
. . Q:$D(DINDEX(DISUB,"IXROOT"))
. . D BACKPAST^DICLIX1(DIFLAGS,.DINDEX,DISUB,DIVAL,.DIDONE) Q
. D TRY
. Q
CLEAN ; clean up after loop, exit
S DINDEX(DISUB)=""
I DISUB>1,$G(DINDEX(DISUB,"PART"))]"" S DINDEX(DISUB)=DINDEX(DISUB,"FROM")
Q
;
CHK ; See whether we have a match or are at the end of the subscripts.
D MATCH I DIDONE,'$G(DINDEX("DONE")),DIMORE 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 $P(DIVAL,$G(DIPART))'="" S DIDONE=1 Q
Q:$G(DINDEX(DISUB,"TO"))=""
I DIFLAGS["p" D BACKPAST^DICLIX1(DIFLAGS,.DINDEX0,DISUB,DIVAL,.DIDONE) Q
I $G(DINDEX(DISUB+1,"TO"))="" D BACKPAST^DICLIX1(DIFLAGS,.DINDEX,DISUB,DIVAL,.DIDONE)
Q
;
LOWSUB ; Find next subscript value from multiple pointed-to files
N I,DILOWNO,DILOWVAL S DILOWNO=+DIFILE("STACK"),DILOWVAL=DIVAL
I DILOWVAL="" D I 'DILOWNO K DIXV Q
. K DIXV(DILOWNO),DIFILE("STACKEND",DILOWNO)
. S DILOWNO=$O(DIXV(0)),DILOWVAL=$G(DIXV(+DILOWNO,1,"NXTVAL"))
. Q
N J S J=DILOWNO
I DILOWVAL'="" F I=0:0 S I=$O(DIFILE("STACKEND",I)) Q:'I I I'=J D
. I DINDEX(1,"WAY")=1,DILOWVAL']]DIXV(I,1,"NXTVAL") Q
. I DINDEX(1,"WAY")=-1,DIXV(I,1,"NXTVAL")']]DILOWVAL Q
. S DILOWNO=I,DILOWVAL=$G(DIXV(DILOWNO,1,"NXTVAL"))
. Q
I DILOWNO'=DIFILE("STACK") D
. I DIVAL'="" S DIXV(+DIFILE("STACK"),1,"NXTVAL")=DIVAL
. S DIFILE("STACK")=DILOWNO_U_DIFILE("STACKEND",DILOWNO)
. S DIVAL=DILOWVAL
. S DIFILE=+$P(DIFILE("STACK"),U,3)
. M DINDEX=DIXV(DILOWNO) Q
Q
;
TRY ; Apply screens to entry. If passed, add entry to output.
S (DIEN,DINDEX(DISUB))=DIVAL
I DIFLAGS["p" D
. S DINDEX0(1,"EXT")=DINDEX(1)
. D BACKTRAK^DICL3(.DIFLAGS,.DIFILE,DIFILE("STACK"),.DIEN,DIFIEN,.DINDEX0,.DINDEX,.DIDENT,.DISCREEN,.DILIST)
. S:$G(DINDEX0("DONE")) (DIDONE,DINDEX("DONE"))=1 Q
I DIFLAGS'["p" D
. N DI0NODE S DI0NODE=$G(@DIFILE(DIFILE)@(DIEN,0))
. Q:$$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE)
. D ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE)
. Q
Q:$G(DIERR)!($G(DINDEX("DONE")))
I DIDENT(-1)=DIDENT(-1,"MAX") D
. I 'DIDENT(-1,"JUST LOOKING") S DIDONE=1,DINDEX("DONE")=1 Q
. ; If called from online DIC help ^DICQ, display list.
. Q:DIFLAGS'["h"
. K DTOUT,DUOUT S DICQ(0,"MAP")=DIDENT(-3)
. D DSP^DICQ1(.DINDEX,.DICQ,.DIC,.DIFILE)
. I $G(DTOUT)!($G(DUOUT)) S (DINDEX("DONE"),DIDONE)=1 Q
. S DILIST("ORDER")=$S(DINDEX("WAY")=1:0,1:DIDENT(-1,"MAX")+1)
. S DIDENT(-1)=0,DIDENT(-1,"JUST LOOKING")=0 Q
Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICLIX 4650 printed Apr 09, 2024@21:54:42 Page 2
DICLIX ;SEA/TOAD,SF/TKW-FileMan: Lister, Search Compound Indexes ;6/5/00 10:13
+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 ;
WALK(DIFLAGS,DINDEX,DIDENT,DIFILE,DIEN,DIFIEN,DISCREEN,DILIST,DINDEX0,DIXV,DIC) ;
+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 IF $GET(DINDEX(DISUB,"USE"))
IF DIVAL'=""
Begin DoDot:1
+6 SET DIVAL=$ORDER(@DINDEX(DISUB,"ROOT")@(DIVAL),-DINDEX(DISUB,"WAY"))
End DoDot:1
+7 ;
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 IF DISUB=1
IF $ORDER(DIXV(0))
DO LOWSUB
+4 SET DISKIP=0
+5 IF DIVAL'=""
IF '$DATA(DINDEX(DISUB,"IXROOT"))
DO CHK
if DISKIP
QUIT
+6 if DIVAL=""
SET DIDONE=1
+7 if DIDONE
QUIT
+8 SET DINDEX(DISUB)=DIVAL
SET DINDEX("AT")=DISUB+1
+9 IF $DATA(DINDEX("ROOTCNG",DISUB+1))
DO BLDTMP^DICLIX1(.DINDEX,.DISCREEN,DIFLAGS,.DIDENT)
+10 DO WALK(.DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DINDEX0,"",.DIC)
+11 SET DINDEX("AT")=DISUB
+12 IF $GET(DINDEX("DONE"))!$GET(DIERR)
SET DIDONE=1
+13 QUIT
End DoDot:2
QUIT
+14 IEN ; otherwise, we're in the IEN subscripts & need to process
+1 +2 IF DIVAL=""
SET DIDONE=1
QUIT
+3 IF DINDEX="B"
NEW DISKIPMN,DIMNEM
SET DISKIPMN=0
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 IF DIFLAGS["M"
SET DISKIPMN=1
QUIT
+7 SET DIMNEM=""
QUIT
End DoDot:2
if DISKIPMN
QUIT
+8 IF $GET(DINDEX(DISUB,"TO"))
Begin DoDot:2
+9 if $DATA(DINDEX(DISUB,"IXROOT"))
QUIT
+10 DO BACKPAST^DICLIX1(DIFLAGS,.DINDEX,DISUB,DIVAL,.DIDONE)
QUIT
End DoDot:2
if DIDONE
QUIT
+11 DO TRY
+12 QUIT
End DoDot:1
if DIDONE!$GET(DIERR)
QUIT
CLEAN ; clean up after loop, exit
+1 SET DINDEX(DISUB)=""
+2 IF DISUB>1
IF $GET(DINDEX(DISUB,"PART"))]""
SET DINDEX(DISUB)=DINDEX(DISUB,"FROM")
+3 QUIT
+4 ;
CHK ; See whether we have a match or are at the end of the subscripts.
+1 DO MATCH
IF DIDONE
IF '$GET(DINDEX("DONE"))
IF DIMORE
Begin DoDot:1
+2 SET DIDONE=0
DO FINDMORE^DICLIX0(DISUB,.DIVAL,DIPART,.DINDEX,.DIMORE)
IF DIVAL=""
SET DIDONE=1
QUIT
+3 DO MATCH
QUIT
End DoDot:1
+4 QUIT
+5 ;
MATCH ; No more subscripts or partial matches, or past our TO value?
+1 if DIVAL=""
QUIT
+2 IF $PIECE(DIVAL,$GET(DIPART))'=""
SET DIDONE=1
QUIT
+3 if $GET(DINDEX(DISUB,"TO"))=""
QUIT
+4 IF DIFLAGS["p"
DO BACKPAST^DICLIX1(DIFLAGS,.DINDEX0,DISUB,DIVAL,.DIDONE)
QUIT
+5 IF $GET(DINDEX(DISUB+1,"TO"))=""
DO BACKPAST^DICLIX1(DIFLAGS,.DINDEX,DISUB,DIVAL,.DIDONE)
+6 QUIT
+7 ;
LOWSUB ; Find next subscript value from multiple pointed-to files
+1 NEW I,DILOWNO,DILOWVAL
SET DILOWNO=+DIFILE("STACK")
SET DILOWVAL=DIVAL
+2 IF DILOWVAL=""
Begin DoDot:1
+3 KILL DIXV(DILOWNO),DIFILE("STACKEND",DILOWNO)
+4 SET DILOWNO=$ORDER(DIXV(0))
SET DILOWVAL=$GET(DIXV(+DILOWNO,1,"NXTVAL"))
+5 QUIT
End DoDot:1
IF 'DILOWNO
KILL DIXV
QUIT
+6 NEW J
SET J=DILOWNO
+7 IF DILOWVAL'=""
FOR I=0:0
SET I=$ORDER(DIFILE("STACKEND",I))
if 'I
QUIT
IF I'=J
Begin DoDot:1
+8 IF DINDEX(1,"WAY")=1
IF DILOWVAL']]DIXV(I,1,"NXTVAL")
QUIT
+9 IF DINDEX(1,"WAY")=-1
IF DIXV(I,1,"NXTVAL")']]DILOWVAL
QUIT
+10 SET DILOWNO=I
SET DILOWVAL=$GET(DIXV(DILOWNO,1,"NXTVAL"))
+11 QUIT
End DoDot:1
+12 IF DILOWNO'=DIFILE("STACK")
Begin DoDot:1
+13 IF DIVAL'=""
SET DIXV(+DIFILE("STACK"),1,"NXTVAL")=DIVAL
+14 SET DIFILE("STACK")=DILOWNO_U_DIFILE("STACKEND",DILOWNO)
+15 SET DIVAL=DILOWVAL
+16 SET DIFILE=+$PIECE(DIFILE("STACK"),U,3)
+17 MERGE DINDEX=DIXV(DILOWNO)
QUIT
End DoDot:1
+18 QUIT
+19 ;
TRY ; Apply screens to entry. If passed, add entry to output.
+1 SET (DIEN,DINDEX(DISUB))=DIVAL
+2 IF DIFLAGS["p"
Begin DoDot:1
+3 SET DINDEX0(1,"EXT")=DINDEX(1)
+4 DO BACKTRAK^DICL3(.DIFLAGS,.DIFILE,DIFILE("STACK"),.DIEN,DIFIEN,.DINDEX0,.DINDEX,.DIDENT,.DISCREEN,.DILIST)
+5 if $GET(DINDEX0("DONE"))
SET (DIDONE,DINDEX("DONE"))=1
QUIT
End DoDot:1
+6 IF DIFLAGS'["p"
Begin DoDot:1
+7 NEW DI0NODE
SET DI0NODE=$GET(@DIFILE(DIFILE)@(DIEN,0))
+8 if $$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE)
QUIT
+9 DO ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE)
+10 QUIT
End DoDot:1
+11 if $GET(DIERR)!($GET(DINDEX("DONE")))
QUIT
+12 IF DIDENT(-1)=DIDENT(-1,"MAX")
Begin DoDot:1
+13 IF 'DIDENT(-1,"JUST LOOKING")
SET DIDONE=1
SET DINDEX("DONE")=1
QUIT
+14 ; If called from online DIC help ^DICQ, display list.
+15 if DIFLAGS'["h"
QUIT
+16 KILL DTOUT,DUOUT
SET DICQ(0,"MAP")=DIDENT(-3)
+17 DO DSP^DICQ1(.DINDEX,.DICQ,.DIC,.DIFILE)
+18 IF $GET(DTOUT)!($GET(DUOUT))
SET (DINDEX("DONE"),DIDONE)=1
QUIT
+19 SET DILIST("ORDER")=$SELECT(DINDEX("WAY")=1:0,1:DIDENT(-1,"MAX")+1)
+20 SET DIDENT(-1)=0
SET DIDENT(-1,"JUST LOOKING")=0
QUIT
End DoDot:1
+21 QUIT
+22 ;
+23 ;
