- DICLIX1 ;SEA/TOAD,SF/TKW-FileMan: Lister, Search Compound Indexes (cont.) ;11/5/99 15: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.
- ;
- BLDTMP(DINDEX,DISCREEN,DIFLAGS,DIDENT) ; Build temporary index of external values when pointer/vp subscript is encountered.
- N DISUB,DIXSAV,DIX,DIDOUT S DIDOUT=0
- S DIX("AT")=DINDEX("AT") K @DINDEX(DIX("AT"),"ROOT")
- N I S I=$S(DIX("AT")=1:1,1:DIX("AT")-1)
- F DISUB=I:1:DINDEX("#")+1 D
- . S (DIXSAV(DISUB),DIX(DISUB))=DINDEX(DISUB)
- . I "VP"[$G(DINDEX(DISUB,"TYPE")) S DIX(DISUB)=""
- D BT1
- F DISUB=DINDEX("AT"):1:DINDEX("#")+1 S DINDEX(DISUB)=DIXSAV(DISUB)
- Q
- ;
- BT1 N DISUB S DISUB=DIX("AT")
- N DIVAL,DISINT,DIDONE,DIPART,DIMORE S DISINT=DIX(DISUB),DIDONE=0
- F D Q:DIDONE
- . S DISINT=$O(@DINDEX(DISUB,"IXROOT")@(DISINT),DINDEX(DISUB,"WAY"))
- . S:DISINT="" DIDONE=1 Q:DIDONE
- . I DISUB'>DINDEX("#") D Q
- . . S DIVAL=DISINT,DIPART=$G(DINDEX(DISUB,"PART")),DIMORE=$G(DINDEX(DISUB,"MORE?"))
- . . I DINDEX(DISUB,"TYPE")="V",$G(DISCREEN("V",DISUB))]"" D Q:DIVAL=""
- . . . N G S G="^"_$P(DISINT,";",2) Q:G="^"
- . . . S:'$D(DINDEX(DISUB,"VP",G)) DIVAL="" Q
- . . I "VP"[DINDEX(DISUB,"TYPE") D I DIVAL="" S DIDONE=1 Q
- . . . S DIVAL=$$EXTERNAL^DIDU(DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD"),"i",DIVAL)
- . . . Q:'$G(DIERR)
- . . . I DIFLAGS["h" K DIERR,^TMP("DIERR",$J) Q
- . . . S DIVAL="",DINDEX("DONE")=1 Q
- . . D CHK^DICLIX I DIDONE D Q
- . . . I $G(DINDEX("DONE")) S DIDOUT=1 Q
- . . . S:DIVAL]"" DIDONE=0 Q
- . . I DISUB=1,"VP"[DINDEX(1,"TYPE") S @DINDEX(1,"ROOT")@(DIVAL)=DISINT
- . . S DINDEX(DISUB)=DIVAL,DIX(DISUB)=DISINT,DIX("AT")=DISUB+1
- . . D BT1
- . . S DIX("AT")=DISUB
- . . I $G(DIDOUT) S DIDONE=1
- . . Q
- . Q:DIDONE
- . I $G(DINDEX(DISUB,"TO")) D Q:DIDONE
- . . D BACKPAST(DIFLAGS,.DINDEX,DISUB,DISINT,.DIDONE)
- . . S:DIDONE DIDOUT=1 Q
- . S @DINDEX(DISUB,"ROOT")@(DISINT)=""
- S DIX(DISUB)="" Q
- ;
- BACKPAST(DIFLAGS,DINDEX,DISUB,DIVAL,DIDONE) ; Have we gone past TO value? Lister only.
- N I,DIOUT S DIOUT=0
- F I=1:1:DISUB D Q:DIOUT
- . N V S V=$S(I=DISUB:DIVAL,1:DINDEX(I))
- . I I=1,DIFLAGS'["p","PV"[DINDEX(1,"TYPE") S V=DINDEX(I,"EXT")
- . Q:V=DINDEX(I,"TO")
- . I DINDEX(I,"WAY")=1,DINDEX(I,"TO")]]V S DIOUT=1 Q
- . I DINDEX(I,"WAY")=-1,V]]DINDEX(I,"TO") S DIOUT=1 Q
- . S DIVAL="",(DIOUT,DIDONE,DINDEX("DONE"))=1 Q
- . Q
- Q:DIOUT
- S DIVAL="",(DIDONE,DINDEX("DONE"))=1 Q
- ;
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICLIX1 2638 printed Mar 13, 2025@21:51 Page 2
- DICLIX1 ;SEA/TOAD,SF/TKW-FileMan: Lister, Search Compound Indexes (cont.) ;11/5/99 15: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 ;
- BLDTMP(DINDEX,DISCREEN,DIFLAGS,DIDENT) ; Build temporary index of external values when pointer/vp subscript is encountered.
- +1 NEW DISUB,DIXSAV,DIX,DIDOUT
- SET DIDOUT=0
- +2 SET DIX("AT")=DINDEX("AT")
- KILL @DINDEX(DIX("AT"),"ROOT")
- +3 NEW I
- SET I=$SELECT(DIX("AT")=1:1,1:DIX("AT")-1)
- +4 FOR DISUB=I:1:DINDEX("#")+1
- Begin DoDot:1
- +5 SET (DIXSAV(DISUB),DIX(DISUB))=DINDEX(DISUB)
- +6 IF "VP"[$GET(DINDEX(DISUB,"TYPE"))
- SET DIX(DISUB)=""
- End DoDot:1
- +7 DO BT1
- +8 FOR DISUB=DINDEX("AT"):1:DINDEX("#")+1
- SET DINDEX(DISUB)=DIXSAV(DISUB)
- +9 QUIT
- +10 ;
- BT1 NEW DISUB
- SET DISUB=DIX("AT")
- +1 NEW DIVAL,DISINT,DIDONE,DIPART,DIMORE
- SET DISINT=DIX(DISUB)
- SET DIDONE=0
- +2 FOR
- Begin DoDot:1
- +3 SET DISINT=$ORDER(@DINDEX(DISUB,"IXROOT")@(DISINT),DINDEX(DISUB,"WAY"))
- +4 if DISINT=""
- SET DIDONE=1
- if DIDONE
- QUIT
- +5 IF DISUB'>DINDEX("#")
- Begin DoDot:2
- +6 SET DIVAL=DISINT
- SET DIPART=$GET(DINDEX(DISUB,"PART"))
- SET DIMORE=$GET(DINDEX(DISUB,"MORE?"))
- +7 IF DINDEX(DISUB,"TYPE")="V"
- IF $GET(DISCREEN("V",DISUB))]""
- Begin DoDot:3
- +8 NEW G
- SET G="^"_$PIECE(DISINT,";",2)
- if G="^"
- QUIT
- +9 if '$DATA(DINDEX(DISUB,"VP",G))
- SET DIVAL=""
- QUIT
- End DoDot:3
- if DIVAL=""
- QUIT
- +10 IF "VP"[DINDEX(DISUB,"TYPE")
- Begin DoDot:3
- +11 SET DIVAL=$$EXTERNAL^DIDU(DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD"),"i",DIVAL)
- +12 if '$GET(DIERR)
- QUIT
- +13 IF DIFLAGS["h"
- KILL DIERR,^TMP("DIERR",$JOB)
- QUIT
- +14 SET DIVAL=""
- SET DINDEX("DONE")=1
- QUIT
- End DoDot:3
- IF DIVAL=""
- SET DIDONE=1
- QUIT
- +15 DO CHK^DICLIX
- IF DIDONE
- Begin DoDot:3
- +16 IF $GET(DINDEX("DONE"))
- SET DIDOUT=1
- QUIT
- +17 if DIVAL]""
- SET DIDONE=0
- QUIT
- End DoDot:3
- QUIT
- +18 IF DISUB=1
- IF "VP"[DINDEX(1,"TYPE")
- SET @DINDEX(1,"ROOT")@(DIVAL)=DISINT
- +19 SET DINDEX(DISUB)=DIVAL
- SET DIX(DISUB)=DISINT
- SET DIX("AT")=DISUB+1
- +20 DO BT1
- +21 SET DIX("AT")=DISUB
- +22 IF $GET(DIDOUT)
- SET DIDONE=1
- +23 QUIT
- End DoDot:2
- QUIT
- +24 if DIDONE
- QUIT
- +25 IF $GET(DINDEX(DISUB,"TO"))
- Begin DoDot:2
- +26 DO BACKPAST(DIFLAGS,.DINDEX,DISUB,DISINT,.DIDONE)
- +27 if DIDONE
- SET DIDOUT=1
- QUIT
- End DoDot:2
- if DIDONE
- QUIT
- +28 SET @DINDEX(DISUB,"ROOT")@(DISINT)=""
- End DoDot:1
- if DIDONE
- QUIT
- +29 SET DIX(DISUB)=""
- QUIT
- +30 ;
- BACKPAST(DIFLAGS,DINDEX,DISUB,DIVAL,DIDONE) ; Have we gone past TO value? Lister only.
- +1 NEW I,DIOUT
- SET DIOUT=0
- +2 FOR I=1:1:DISUB
- Begin DoDot:1
- +3 NEW V
- SET V=$SELECT(I=DISUB:DIVAL,1:DINDEX(I))
- +4 IF I=1
- IF DIFLAGS'["p"
- IF "PV"[DINDEX(1,"TYPE")
- SET V=DINDEX(I,"EXT")
- +5 if V=DINDEX(I,"TO")
- QUIT
- +6 IF DINDEX(I,"WAY")=1
- IF DINDEX(I,"TO")]]V
- SET DIOUT=1
- QUIT
- +7 IF DINDEX(I,"WAY")=-1
- IF V]]DINDEX(I,"TO")
- SET DIOUT=1
- QUIT
- +8 SET DIVAL=""
- SET (DIOUT,DIDONE,DINDEX("DONE"))=1
- QUIT
- +9 QUIT
- End DoDot:1
- if DIOUT
- QUIT
- +10 if DIOUT
- QUIT
- +11 SET DIVAL=""
- SET (DIDONE,DINDEX("DONE"))=1
- QUIT
- +12 ;
- +13 ;
