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 Apr 09, 2024@21:53:03 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 ;
