DICF2 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 3 (All Indexes) ;12/17/99 08:24 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**4,20**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
CHKALL(DIFILE,DIEN,DIFIEN,DIFLAGS,DIVALUE,DISCREEN,DINUMBER,DIFORCE,DINDEX,DIDENT,DILIST,DIC,DIY,DIYX) ;
; Loop through all indexes to be searched, perform data type
; transforms on lookup values.
N DIOUT
I DIFLAGS["O",DIFLAGS'["p" S DIOUT=DIFLAGS N DIFLAGS S DIFLAGS=DIOUT_"X"
S DIOUT=0 N DISKIP
41 F D Q:$G(DIERR)!($G(DINDEX("DONE")))!DIOUT
. S DISKIP=0
. N DILINK S DILINK=DIFILE_U_DINDEX
. I DINDEX="#" D
. . S DIFILE("CHAIN",DILINK)=""
. . Q:+$P(DIVALUE,"E")'=DIVALUE Q:'$D(@DIFILE(DIFILE)@(DIVALUE))
. . N DIEN S DIEN=DIVALUE D ENTRY^DICF1 Q
. I '$D(DIFILE("CHAIN",DILINK)) D K DIFILE("CHAIN",DILINK)
. . S DIFILE("CHAIN",DILINK)=""
. . D:DIFLAGS'["Q" PREPIX(.DIFILE,DIFLAGS,.DINDEX,.DIVALUE,.DISKIP)
. . I 'DISKIP D CHKONE^DICF3(.DIFLAGS,.DIVALUE,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DIC,.DIY,.DIYX)
. . D CLEANIX(.DINDEX,.DIVALUE) Q
43 . I $G(DIERR)!($G(DINDEX("DONE"))) Q
. I DIFLAGS["l" S (DIOUT,DINDEX("DONE"))=1 Q
. D NXTINDX(.DINDEX,.DIFORCE,.DIFILE,.DIFLAGS,.DIVALUE,DINUMBER)
. I DINDEX="" D Q:DINDEX=""
. . S DIOUT=1
. . Q:DIFLAGS'["O" Q:DIFLAGS'["X" Q:DIFLAGS["p" Q:DIDENT(-1)
. . S DIFLAGS=$TR(DIFLAGS,"X"),DIOUT=0,DIFORCE(1)=1
. . S DINDEX=$S(DIFLAGS["l":DINDEX("START"),DIFORCE:$P(DIFORCE(0),U),1:$$DINDEX^DICL(DIFILE,DIFLAGS))
. . I DINDEX="" S DIOUT=1 Q
. . D FIRSTIDX(.DINDEX,.DIFORCE,.DIFILE,DIFLAGS,.DIVALUE,DINUMBER)
. . Q
. D
. . N DICRSR S DICRSR=0
. . I DIFLAGS["P" D Q:'DICRSR
. . . F S DICRSR=$O(DIDENT(DICRSR)) Q:'DICRSR Q:$D(DIDENT(DICRSR,0,1,"E"))
. . . Q
. . Q:'$D(DIDENT(DICRSR,0,1,"E"))
. . N DISAVNO,DISAVENT S DISAVNO=DINDEX("#"),DINDEX("#")=1,DISAVENT=$G(DIDENT),DIDENT="IXE"
. . D THROW^DICU11(DIFLAGS,.DIDENT,"IXE",DICRSR,1,"E",.DINDEX,1)
. . S DINDEX("#")=DISAVNO,DIDENT=DISAVENT Q
. Q
Q
;
PREPIX(DIFILE,DIFLAGS,DINDEX,DIVALUE,DISKIP) ;
; CHKALL--lookup index data type, add transform values to list
N DISUB,DITYPE
F DISUB=1:1:DINDEX("#") D:DIVALUE(DISUB)]"" Q:$G(DIERR)
. I $G(DINDEX("IXTYPE"))="S" D Q
. . N X S X=$$SOUNDEX^DICF5(DINDEX(DISUB)) Q:'X
. . S DIVALUE(DISUB,5)=X Q
. S DITYPE=DINDEX(DISUB,"TYPE")
. I DITYPE["F"!(DITYPE["N") D
. . Q:$G(DINDEX(DISUB,"TRANCODE"))=""
. . N X S X=DIVALUE(DISUB) X DINDEX(DISUB,"TRANCODE") Q:X=""
. . S DIVALUE(DISUB,5)=X
. . Q
. N DINODE S DINODE=$G(^DD(+DINDEX(DISUB,"FILE"),+DINDEX(DISUB,"FIELD"),0))
. I DITYPE["D" D PREPD^DICF5(DISUB,.DINDEX,DINODE,.DIVALUE) Q
. I DITYPE["S" D PREPS^DICF5(DIFLAGS,DISUB,.DINDEX,DINODE,.DIVALUE) Q
. I DITYPE'["P",DITYPE'["V" Q
. I DISUB'=1 D POINT^DICF5(DISUB,DIFLAGS,.DIFILE,.DINDEX,.DIVALUE,.DISCREEN) Q
. D POINT^DICF4(.DIFILE,.DIFLAGS,.DINDEX,.DIDENT,.DIEN,DIFIEN,.DISCREEN,.DIVALUE,.DIC,.DIFORCE)
. I '$D(DINDEX(1,"IXROOT"))!($G(DIERR)) S DISKIP=1
. I $G(DTOUT)!($G(DIROUT)) S (DISKIP,DINDEX("DONE"))=1
. Q:DISKIP
. Q:$G(DINDEX(1,"TRANCODE"))=""
. N DII,X
. S DII="" F S DII=$O(@DINDEX(1,"ROOT")@(DII)) Q:DII="" D
. . K @DINDEX(1,"ROOT")@(DII)
. . S X=$P(DII,"^",2) X DINDEX(1,"TRANCODE") Q:X=""
. . S X=$P(DII,"^")_"^"_X,@DINDEX(1,"ROOT")@(X)="" Q
. Q
Q
;
CLEANIX(DINDEX,DIVALUE) ;
; CHKALL--clear transform values for this index from DIVALUE arrays
; clear temporary list of pointed-to entries.
N I,DISUB
F DISUB=1:1:DINDEX("#") D
. I $G(DINDEX(DISUB,"IXROOT"))]"" D
. . I DISUB=1,DIFLAGS["l" S I=$O(@DINDEX(DISUB,"ROOT")@("")),DS("INT")=$P(I,U,2)
. . S I=$P(DINDEX(DISUB,"ROOT"),",""B"")",1) Q:I=""
. . K @(I_")") Q
. S I=4
. F S I=$O(DIVALUE(DISUB,I)) Q:'I K DIVALUE(DISUB,I)
. Q
Q
;
FIRSTIDX(DINDEX,DIFORCE,DIFILE,DIFLAGS,DIVALUE,DINUMBER) ;
; Return data for starting index before second loop when flags["O"
D N3 Q
;
NXTINDX(DINDEX,DIFORCE,DIFILE,DIFLAGS,DIVALUE,DINUMBER) ;
; Return next index
N D,DIGO,I,J,K,DIX1,DIX2,DIOK,DIOLDL
S D=DINDEX,I=$G(DINDEX("START")),K=$G(DINDEX("MAXSUB"))
D:DIFLAGS'["h"
. F J=1:1:DINDEX("#") S DIOLDL(J)=DINDEX(J,"LENGTH")
K DINDEX S DINDEX=D,DINDEX("WAY")=1
S:I]"" DINDEX("START")=I S:K]"" DINDEX("MAXSUB")=K
S (DIGO,DIOK)=0
N1 I DIFORCE F D Q:DIOK!(DIGO)
. I DIFLAGS["M",DIFORCE(1)=1,$P(DIFORCE(0),U,2)="" S DIGO=1 Q
. S DIFORCE(1)=DIFORCE(1)+1,DINDEX=$P(DIFORCE(0),U,DIFORCE(1))
. I DINDEX="#",DIFLAGS'["l",DIFLAGS'["h" S DIOK=1 Q
. S:DINDEX=-1 DINDEX="" I DINDEX="" S DIOK=1 Q
. I $O(^DD(DIFILE,0,"IX",DINDEX,0)),$$IDXOK(DIFILE,DINDEX) S DIOK=1 Q
. S I=$O(^DD("IX","BB",DIFILE,DINDEX,0)) Q:'I
. S DIOK=1 Q
N2 I ('DIFORCE)!DIGO D
. S (DIX1,DIX2)=DINDEX
. F S DIX1=$O(^DD(DIFILE,0,"IX",DIX1)) Q:DIX1="" Q:$$IDXOK(DIFILE,DIX1)
. S DIOK=0 F S DIX2=$O(^DD("IX","BB",DIFILE,DIX2)) Q:DIX2="" D Q:DIOK
. . S I=$O(^DD("IX","BB",DIFILE,DIX2,0)) Q:'I
. . Q:$P($G(^DD("IX",I,0)),U,14)'["L"
. . S J=$O(^DD("IX",I,11.1,"AC",1,0)) Q:'J Q:$G(^DD("IX",I,11.1,J,0))=""
. . S DIOK=1 Q
. I DIX1'="",DIX2=""!(DIX2]DIX1) S DINDEX=DIX1 Q
. S DINDEX=DIX2 Q
. Q
N3 Q:DINDEX="" Q:DIFLAGS["h"
D INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,"",.DIVALUE,DINUMBER,.DISCREEN)
I DINDEX("#")>1 F D=1:1:DINDEX("#") S DIVALUE(D)=$G(DIVALUE(D))
N DINEWVAL S DINEWVAL=0 D
. N J F J=1:1:DINDEX("#") I DIVALUE(J)]"",DINDEX(J,"LENGTH")'=$G(DIOLDL(J)) S DINEWVAL=1 Q
. I DINEWVAL D XFORM^DICF1(DIFLAGS,.DIVALUE,.DISCREEN,.DINDEX)
Q
;
IDXOK(DIFILE,%) ; See whether selected index exists in 1 nodes of DD
N DIX,%Y,DD,X Q:%="" 0
S DIX=$O(^DD(DIFILE,0,"IX",%,0)) Q:'DIX 0
S %Y=$O(^DD(DIFILE,0,"IX",%,DIX,0)) Q:'%Y 0
F DD=0:0 S DD=$O(^DD(DIX,%Y,1,DD)) Q:'DD S X=$P($G(^(DD,0)),U,2) Q:X=%
Q:'DD 0
Q 1
;
DICF2 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 3 (All Indexes) ;12/17/99 08:24 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**4,20**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
+4 ;
CHKALL(DIFILE,DIEN,DIFIEN,DIFLAGS,DIVALUE,DISCREEN,DINUMBER,DIFORCE,DINDEX,DIDENT,DILIST,DIC,DIY,DIYX) ;
+1 ; Loop through all indexes to be searched, perform data type
+2 ; transforms on lookup values.
+3 NEW DIOUT
+4 IF DIFLAGS["O"
IF DIFLAGS'["p"
SET DIOUT=DIFLAGS
NEW DIFLAGS
SET DIFLAGS=DIOUT_"X"
+5 SET DIOUT=0
NEW DISKIP
41 FOR
Begin DoDot:1
+1 SET DISKIP=0
+2 NEW DILINK
SET DILINK=DIFILE_U_DINDEX
+3 IF DINDEX="#"
Begin DoDot:2
+4 SET DIFILE("CHAIN",DILINK)=""
+5 IF +$PIECE(DIVALUE,"E")'=DIVALUE
QUIT
IF '$DATA(@DIFILE(DIFILE)@(DIVALUE))
QUIT
+6 NEW DIEN
SET DIEN=DIVALUE
DO ENTRY^DICF1
QUIT
End DoDot:2
+7 IF '$DATA(DIFILE("CHAIN",DILINK))
Begin DoDot:2
+8 SET DIFILE("CHAIN",DILINK)=""
+9 IF DIFLAGS'["Q"
DO PREPIX(.DIFILE,DIFLAGS,.DINDEX,.DIVALUE,.DISKIP)
+10 IF 'DISKIP
DO CHKONE^DICF3(.DIFLAGS,.DIVALUE,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DIC,.DIY,.DIYX)
+11 DO CLEANIX(.DINDEX,.DIVALUE)
QUIT
End DoDot:2
KILL DIFILE("CHAIN",DILINK)
43 IF $GET(DIERR)!($GET(DINDEX("DONE")))
QUIT
+1 IF DIFLAGS["l"
SET (DIOUT,DINDEX("DONE"))=1
QUIT
+2 DO NXTINDX(.DINDEX,.DIFORCE,.DIFILE,.DIFLAGS,.DIVALUE,DINUMBER)
+3 IF DINDEX=""
Begin DoDot:2
+4 SET DIOUT=1
+5 IF DIFLAGS'["O"
QUIT
IF DIFLAGS'["X"
QUIT
IF DIFLAGS["p"
QUIT
IF DIDENT(-1)
QUIT
+6 SET DIFLAGS=$TRANSLATE(DIFLAGS,"X")
SET DIOUT=0
SET DIFORCE(1)=1
+7 SET DINDEX=$SELECT(DIFLAGS["l":DINDEX("START"),DIFORCE:$PIECE(DIFORCE(0),U),1:$$DINDEX^DICL(DIFILE,DIFLAGS))
+8 IF DINDEX=""
SET DIOUT=1
QUIT
+9 DO FIRSTIDX(.DINDEX,.DIFORCE,.DIFILE,DIFLAGS,.DIVALUE,DINUMBER)
+10 QUIT
End DoDot:2
IF DINDEX=""
QUIT
+11 Begin DoDot:2
+12 NEW DICRSR
SET DICRSR=0
+13 IF DIFLAGS["P"
Begin DoDot:3
+14 FOR
SET DICRSR=$ORDER(DIDENT(DICRSR))
IF 'DICRSR
QUIT
IF $DATA(DIDENT(DICRSR,0,1,"E"))
QUIT
+15 QUIT
End DoDot:3
IF 'DICRSR
QUIT
+16 IF '$DATA(DIDENT(DICRSR,0,1,"E"))
QUIT
+17 NEW DISAVNO,DISAVENT
SET DISAVNO=DINDEX("#")
SET DINDEX("#")=1
SET DISAVENT=$GET(DIDENT)
SET DIDENT="IXE"
+18 DO THROW^DICU11(DIFLAGS,.DIDENT,"IXE",DICRSR,1,"E",.DINDEX,1)
+19 SET DINDEX("#")=DISAVNO
SET DIDENT=DISAVENT
QUIT
End DoDot:2
+20 QUIT
End DoDot:1
IF $GET(DIERR)!($GET(DINDEX("DONE")))!DIOUT
QUIT
+21 QUIT
+22 ;
PREPIX(DIFILE,DIFLAGS,DINDEX,DIVALUE,DISKIP) ;
+1 ; CHKALL--lookup index data type, add transform values to list
+2 NEW DISUB,DITYPE
+3 FOR DISUB=1:1:DINDEX("#")
IF DIVALUE(DISUB)]""
Begin DoDot:1
+4 IF $GET(DINDEX("IXTYPE"))="S"
Begin DoDot:2
+5 NEW X
SET X=$$SOUNDEX^DICF5(DINDEX(DISUB))
IF 'X
QUIT
+6 SET DIVALUE(DISUB,5)=X
QUIT
End DoDot:2
QUIT
+7 SET DITYPE=DINDEX(DISUB,"TYPE")
+8 IF DITYPE["F"!(DITYPE["N")
Begin DoDot:2
+9 IF $GET(DINDEX(DISUB,"TRANCODE"))=""
QUIT
+10 NEW X
SET X=DIVALUE(DISUB)
XECUTE DINDEX(DISUB,"TRANCODE")
IF X=""
QUIT
+11 SET DIVALUE(DISUB,5)=X
+12 QUIT
End DoDot:2
+13 NEW DINODE
SET DINODE=$GET(^DD(+DINDEX(DISUB,"FILE"),+DINDEX(DISUB,"FIELD"),0))
+14 IF DITYPE["D"
DO PREPD^DICF5(DISUB,.DINDEX,DINODE,.DIVALUE)
QUIT
+15 IF DITYPE["S"
DO PREPS^DICF5(DIFLAGS,DISUB,.DINDEX,DINODE,.DIVALUE)
QUIT
+16 IF DITYPE'["P"
IF DITYPE'["V"
QUIT
+17 IF DISUB'=1
DO POINT^DICF5(DISUB,DIFLAGS,.DIFILE,.DINDEX,.DIVALUE,.DISCREEN)
QUIT
+18 DO POINT^DICF4(.DIFILE,.DIFLAGS,.DINDEX,.DIDENT,.DIEN,DIFIEN,.DISCREEN,.DIVALUE,.DIC,.DIFORCE)
+19 IF '$DATA(DINDEX(1,"IXROOT"))!($GET(DIERR))
SET DISKIP=1
+20 IF $GET(DTOUT)!($GET(DIROUT))
SET (DISKIP,DINDEX("DONE"))=1
+21 IF DISKIP
QUIT
+22 IF $GET(DINDEX(1,"TRANCODE"))=""
QUIT
+23 NEW DII,X
+24 SET DII=""
FOR
SET DII=$ORDER(@DINDEX(1,"ROOT")@(DII))
IF DII=""
QUIT
Begin DoDot:2
+25 KILL @DINDEX(1,"ROOT")@(DII)
+26 SET X=$PIECE(DII,"^",2)
XECUTE DINDEX(1,"TRANCODE")
IF X=""
QUIT
+27 SET X=$PIECE(DII,"^")_"^"_X
SET @DINDEX(1,"ROOT")@(X)=""
QUIT
End DoDot:2
+28 QUIT
End DoDot:1
IF $GET(DIERR)
QUIT
+29 QUIT
+30 ;
CLEANIX(DINDEX,DIVALUE) ;
+1 ; CHKALL--clear transform values for this index from DIVALUE arrays
+2 ; clear temporary list of pointed-to entries.
+3 NEW I,DISUB
+4 FOR DISUB=1:1:DINDEX("#")
Begin DoDot:1
+5 IF $GET(DINDEX(DISUB,"IXROOT"))]""
Begin DoDot:2
+6 IF DISUB=1
IF DIFLAGS["l"
SET I=$ORDER(@DINDEX(DISUB,"ROOT")@(""))
SET DS("INT")=$PIECE(I,U,2)
+7 SET I=$PIECE(DINDEX(DISUB,"ROOT"),",""B"")",1)
IF I=""
QUIT
+8 KILL @(I_")")
QUIT
End DoDot:2
+9 SET I=4
+10 FOR
SET I=$ORDER(DIVALUE(DISUB,I))
IF 'I
QUIT
KILL DIVALUE(DISUB,I)
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
FIRSTIDX(DINDEX,DIFORCE,DIFILE,DIFLAGS,DIVALUE,DINUMBER) ;
+1 ; Return data for starting index before second loop when flags["O"
+2 DO N3
QUIT
+3 ;
NXTINDX(DINDEX,DIFORCE,DIFILE,DIFLAGS,DIVALUE,DINUMBER) ;
+1 ; Return next index
+2 NEW D,DIGO,I,J,K,DIX1,DIX2,DIOK,DIOLDL
+3 SET D=DINDEX
SET I=$GET(DINDEX("START"))
SET K=$GET(DINDEX("MAXSUB"))
+4 IF DIFLAGS'["h"
Begin DoDot:1
+5 FOR J=1:1:DINDEX("#")
SET DIOLDL(J)=DINDEX(J,"LENGTH")
End DoDot:1
+6 KILL DINDEX
SET DINDEX=D
SET DINDEX("WAY")=1
+7 IF I]""
SET DINDEX("START")=I
IF K]""
SET DINDEX("MAXSUB")=K
+8 SET (DIGO,DIOK)=0
N1 IF DIFORCE
FOR
Begin DoDot:1
+1 IF DIFLAGS["M"
IF DIFORCE(1)=1
IF $PIECE(DIFORCE(0),U,2)=""
SET DIGO=1
QUIT
+2 SET DIFORCE(1)=DIFORCE(1)+1
SET DINDEX=$PIECE(DIFORCE(0),U,DIFORCE(1))
+3 IF DINDEX="#"
IF DIFLAGS'["l"
IF DIFLAGS'["h"
SET DIOK=1
QUIT
+4 IF DINDEX=-1
SET DINDEX=""
IF DINDEX=""
SET DIOK=1
QUIT
+5 IF $ORDER(^DD(DIFILE,0,"IX",DINDEX,0))
IF $$IDXOK(DIFILE,DINDEX)
SET DIOK=1
QUIT
+6 SET I=$ORDER(^DD("IX","BB",DIFILE,DINDEX,0))
IF 'I
QUIT
+7 SET DIOK=1
QUIT
End DoDot:1
IF DIOK!(DIGO)
QUIT
N2 IF ('DIFORCE)!DIGO
Begin DoDot:1
+1 SET (DIX1,DIX2)=DINDEX
+2 FOR
SET DIX1=$ORDER(^DD(DIFILE,0,"IX",DIX1))
IF DIX1=""
QUIT
IF $$IDXOK(DIFILE,DIX1)
QUIT
+3 SET DIOK=0
FOR
SET DIX2=$ORDER(^DD("IX","BB",DIFILE,DIX2))
IF DIX2=""
QUIT
Begin DoDot:2
+4 SET I=$ORDER(^DD("IX","BB",DIFILE,DIX2,0))
IF 'I
QUIT
+5 IF $PIECE($GET(^DD("IX",I,0)),U,14)'["L"
QUIT
+6 SET J=$ORDER(^DD("IX",I,11.1,"AC",1,0))
IF 'J
QUIT
IF $GET(^DD("IX",I,11.1,J,0))=""
QUIT
+7 SET DIOK=1
QUIT
End DoDot:2
IF DIOK
QUIT
+8 IF DIX1'=""
IF DIX2=""!(DIX2]DIX1)
SET DINDEX=DIX1
QUIT
+9 SET DINDEX=DIX2
QUIT
+10 QUIT
End DoDot:1
N3 IF DINDEX=""
QUIT
IF DIFLAGS["h"
QUIT
+1 DO INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,"",.DIVALUE,DINUMBER,.DISCREEN)
+2 IF DINDEX("#")>1
FOR D=1:1:DINDEX("#")
SET DIVALUE(D)=$GET(DIVALUE(D))
+3 NEW DINEWVAL
SET DINEWVAL=0
Begin DoDot:1
+4 NEW J
FOR J=1:1:DINDEX("#")
IF DIVALUE(J)]""
IF DINDEX(J,"LENGTH")'=$GET(DIOLDL(J))
SET DINEWVAL=1
QUIT
+5 IF DINEWVAL
DO XFORM^DICF1(DIFLAGS,.DIVALUE,.DISCREEN,.DINDEX)
End DoDot:1
+6 QUIT
+7 ;
IDXOK(DIFILE,%) ; See whether selected index exists in 1 nodes of DD
+1 NEW DIX,%Y,DD,X
IF %=""
QUIT 0
+2 SET DIX=$ORDER(^DD(DIFILE,0,"IX",%,0))
IF 'DIX
QUIT 0
+3 SET %Y=$ORDER(^DD(DIFILE,0,"IX",%,DIX,0))
IF '%Y
QUIT 0
+4 FOR DD=0:0
SET DD=$ORDER(^DD(DIX,%Y,1,DD))
IF 'DD
QUIT
SET X=$PIECE($GET(^(DD,0)),U,2)
IF X=%
QUIT
+5 IF 'DD
QUIT 0
+6 QUIT 1
+7 ;
