- 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 Mar 13, 2025@21:50:50 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 ;
