DICUIX ;SEA/TOAD,SF/TKW-FileMan: Lookup Tools, Indexes ;19APR2011
;;22.0;VA FileMan;**20,28,67,164,165**;Mar 30, 1999;Build 34
;Per VHA Directive 2004-038, this routine should not be modified.
;
INDEX(DIFILE,DIFLAGS,DINDEX,DIFROM,DIPART,DINUMBER,DISCREEN,DILIST,DIOUT) ;
;
; build DINDEX array data for index
;
I1 ; try to find Index in Index file
;
N DICODE,DIGET,DILENGTH,DINODE,DISUB,DITEMP,DITEMP2,DITO,DITOIEN,DITYPE,DIWAY,DIXIEN
S DINDEX("FLIST")="",DINDEX("AT")=1,DIFROM("IEN")=+$G(DIFROM("IEN")),DIXIEN="",DIGET=1
S:DINDEX'="#" DIXIEN=$O(^DD("IX","BB",DIFILE,DINDEX,""))
I 'DIXIEN D XREF(.DIFILE,.DIFLAGS,.DINDEX,.DIPART,.DIFROM) Q
;
I2 ; in Index file, build list of subscript data
;
S DINODE=^DD("IX",DIXIEN,0)
S DINDEX("IXTYPE")=$P(DINODE,U,4) S:DIFLAGS["4" DINDEX("IXFILE")=DIXIEN
S DINDEX("#")=0
S DISUB=$O(^DD("IX",DIXIEN,11.1,"AC","Z"),-1)
I $G(DIFROM(DISUB+1)) M DIFROM("IEN")=DIFROM(DISUB+1)
S (DISUB,DIOUT)=0 N S
F D Q:'DISUB Q:DIOUT
. S DISUB=$O(^DD("IX",DIXIEN,11.1,"AC",DISUB)) Q:'DISUB S S=$O(^(DISUB,0)) Q:'S
. S DINDEX("#")=DISUB,DIGET=1
. S DINODE=$G(^DD("IX",DIXIEN,11.1,S,0))
. I DIFLAGS["l" N X D S DINDEX(DISUB,"PROMPT")=X
. . S X=$P(DINODE,U,8) Q:X]""
. . I $P(DINODE,U,3),$P(DINODE,U,4) S X=$P($G(^DD($P(DINODE,U,3),$P(DINODE,U,4),0)),U)
. . Q
. S DINDEX(DISUB,"FIELD")=$P(DINODE,U,4)
. S DINDEX(DISUB,"FILE")=$P(DINODE,U,3)
. I $P(DINODE,U,2)["C"!(DINDEX(DISUB,"FILE")="") S DINDEX(DISUB,"FIELD")=""
. I DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD") D
. . I $G(^DD("IX",DIXIEN,11.1,S,4))]"" S DINDEX(DISUB,"TRANCODE")=^(4)
. . I $G(^DD("IX",DIXIEN,11.1,S,2))]"" D
. . . I $G(^DD("IX",DIXIEN,11.1,S,3))="" S DIGET=0 Q
. . . S DINDEX(DISUB,"TRANOUT")=^DD("IX",DIXIEN,11.1,S,3),DIGET=3 Q
. . I "KSMU"[DINDEX("IXTYPE") S DIGET=2
. . Q
. S DILENGTH=$P(DINODE,U,5) I 'DILENGTH S DILENGTH=30 ;GFT
. S DIWAY=$S($P(DINODE,U,7)="B":-1,1:1)
. D COMMON1^DICUIX2
. Q
I DIOUT S @DILIST@(0)="0^"_DINUMBER_"^0" D OUT^DICL Q
D:DIFLAGS'["q" COMMON2^DICUIX2
S DINDEX("FLIST")=DINDEX("FLIST")_"^"
I DIFLAGS'["l",DIFLAGS'["h" Q
N F,F1,F2,I S F=DINDEX("FLIST")
F I=1:1:DINDEX("#") I $G(DINDEX(I,"GETEXT"))=0 S F1=$G(DINDEX(I,"FILE")),F2=$G(DINDEX(I,"FIELD")) I F1=DIFILEI,F2 D
. S F1=$F(F,("^"_F2_"^")) Q:'F1 S F1=F1-2
. S $E(F,(F1-$L(F2)),F1)="" Q
S DINDEX("FLISTD")=F Q
;
XREF(DIFILE,DIFLAGS,DINDEX,DIPART,DIFROM) ;
; Index is in "IX" nodes
;
X1 ; Set DINDEX for search through upright file
;
I DINDEX="#" D Q
. S DINDEX("#")=0,DINDEX(1,"FILE")=DIFILE,DINDEX(1,"ROOT")=DIFILE(DIFILE),DINDEX(1,"TYPE")="N"
. N X S X=$S($G(DIFROM(1)):DIFROM(1),DIPART(1):DIPART(1),1:$G(DIFROM("IEN")))
. S (DIFROM,DIFROM(1))=X S:X DIFROM("IEN")=X
. I DIFLAGS["l"!(DIFLAGS["h") S DINDEX("FLISTD")=""
. D:DIFLAGS'["q" COMMON2^DICUIX2 Q
S DINDEX("#")=1,DINDEX("IXTYPE")="R"
S DINDEX(1,"FILE")=$O(^DD(DIFILE,0,"IX",DINDEX,""))
;
X2 ; Build DINDEX for index in IX nodes.
;
S DIOUT=0,DILENGTH=30
S DINDEX(1,"FIELD")=""
I DINDEX(1,"FILE") S DINDEX(1,"FIELD")=$O(^DD(DIFILE,0,"IX",DINDEX,DINDEX(1,"FILE"),""))
I DINDEX(1,"FIELD")="",DINDEX="B" D
. S DINDEX(1,"FILE")=DIFILE
. S DINDEX(1,"FIELD")=.01 Q
I DIFLAGS[3,DINDEX="B",'$D(@DIFILE(DIFILE)@("B")) D
. D TMPB^DICUIX1(.DITEMP,DIFILE)
. S DIFILE(DIFILE,"NO B")=DITEMP Q
I DIFLAGS["l" S DINDEX(1,"PROMPT")=""
I DINDEX(1,"FILE"),DINDEX(1,"FIELD") D I DINDEX("IXTYPE")="*" K DINDEX S DINDEX="" Q
. I DIFLAGS["l" S DINDEX(1,"PROMPT")=$P($G(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0)),U)
. N I,X,Y
. F I=0:0 S I=$O(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),1,I)) Q:'I S X=$G(^(I,0)) I $P(X,U,2)=DINDEX S Y=$G(^(1)) D Q
. . S X=$E($P(X,U,3),1,2)
. . S DINDEX("IXTYPE")=$S(X="":"R",X="KW":"K",X="SO":"S",(X="TR")!(X="BU"):"*",X]"":X,1:"R")
. . I "KSMU"[DINDEX("IXTYPE") S DIGET=2
. . S DILENGTH=+$P(Y,"$E(X,1,",2)
. . S:'DILENGTH DILENGTH=30 Q ;!(DILENGTH>100)
. Q
I $G(DIFROM(2)) S DIFROM("IEN")=DIFROM(2)
S DISUB=1,DIWAY=1,DIOUT=0
N I,X,Y
D COMMON1^DICUIX2
I DIOUT S @DILIST@(0)="0^"_DINUMBER_"^0" D OUT^DICL Q
D:DIFLAGS'["q" COMMON2^DICUIX2
S DINDEX("FLIST")=DINDEX("FLIST")_"^"
I DIFLAGS["l"!(DIFLAGS["h") D
. I DIGET=2 S DINDEX("FLISTD")="^^" Q
. S DINDEX("FLISTD")=DINDEX("FLIST") Q
S DITEMP=$G(DIFILE(DIFILE,"NO B")) I DITEMP]"" D BLDB^DICUIX1(DIFILE(DIFILE),DITEMP)
Q
;
;
DICUIX ;SEA/TOAD,SF/TKW-FileMan: Lookup Tools, Indexes ;19APR2011
+1 ;;22.0;VA FileMan;**20,28,67,164,165**;Mar 30, 1999;Build 34
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
INDEX(DIFILE,DIFLAGS,DINDEX,DIFROM,DIPART,DINUMBER,DISCREEN,DILIST,DIOUT) ;
+1 ;
+2 ; build DINDEX array data for index
+3 ;
I1 ; try to find Index in Index file
+1 ;
+2 NEW DICODE,DIGET,DILENGTH,DINODE,DISUB,DITEMP,DITEMP2,DITO,DITOIEN,DITYPE,DIWAY,DIXIEN
+3 SET DINDEX("FLIST")=""
SET DINDEX("AT")=1
SET DIFROM("IEN")=+$GET(DIFROM("IEN"))
SET DIXIEN=""
SET DIGET=1
+4 IF DINDEX'="#"
SET DIXIEN=$ORDER(^DD("IX","BB",DIFILE,DINDEX,""))
+5 IF 'DIXIEN
DO XREF(.DIFILE,.DIFLAGS,.DINDEX,.DIPART,.DIFROM)
QUIT
+6 ;
I2 ; in Index file, build list of subscript data
+1 ;
+2 SET DINODE=^DD("IX",DIXIEN,0)
+3 SET DINDEX("IXTYPE")=$PIECE(DINODE,U,4)
IF DIFLAGS["4"
SET DINDEX("IXFILE")=DIXIEN
+4 SET DINDEX("#")=0
+5 SET DISUB=$ORDER(^DD("IX",DIXIEN,11.1,"AC","Z"),-1)
+6 IF $GET(DIFROM(DISUB+1))
MERGE DIFROM("IEN")=DIFROM(DISUB+1)
+7 SET (DISUB,DIOUT)=0
NEW S
+8 FOR
Begin DoDot:1
+9 SET DISUB=$ORDER(^DD("IX",DIXIEN,11.1,"AC",DISUB))
IF 'DISUB
QUIT
SET S=$ORDER(^(DISUB,0))
IF 'S
QUIT
+10 SET DINDEX("#")=DISUB
SET DIGET=1
+11 SET DINODE=$GET(^DD("IX",DIXIEN,11.1,S,0))
+12 IF DIFLAGS["l"
NEW X
Begin DoDot:2
+13 SET X=$PIECE(DINODE,U,8)
IF X]""
QUIT
+14 IF $PIECE(DINODE,U,3)
IF $PIECE(DINODE,U,4)
SET X=$PIECE($GET(^DD($PIECE(DINODE,U,3),$PIECE(DINODE,U,4),0)),U)
+15 QUIT
End DoDot:2
SET DINDEX(DISUB,"PROMPT")=X
+16 SET DINDEX(DISUB,"FIELD")=$PIECE(DINODE,U,4)
+17 SET DINDEX(DISUB,"FILE")=$PIECE(DINODE,U,3)
+18 IF $PIECE(DINODE,U,2)["C"!(DINDEX(DISUB,"FILE")="")
SET DINDEX(DISUB,"FIELD")=""
+19 IF DINDEX(DISUB,"FILE")
IF DINDEX(DISUB,"FIELD")
Begin DoDot:2
+20 IF $GET(^DD("IX",DIXIEN,11.1,S,4))]""
SET DINDEX(DISUB,"TRANCODE")=^(4)
+21 IF $GET(^DD("IX",DIXIEN,11.1,S,2))]""
Begin DoDot:3
+22 IF $GET(^DD("IX",DIXIEN,11.1,S,3))=""
SET DIGET=0
QUIT
+23 SET DINDEX(DISUB,"TRANOUT")=^DD("IX",DIXIEN,11.1,S,3)
SET DIGET=3
QUIT
End DoDot:3
+24 IF "KSMU"[DINDEX("IXTYPE")
SET DIGET=2
+25 QUIT
End DoDot:2
+26 ;GFT
SET DILENGTH=$PIECE(DINODE,U,5)
IF 'DILENGTH
SET DILENGTH=30
+27 SET DIWAY=$SELECT($PIECE(DINODE,U,7)="B":-1,1:1)
+28 DO COMMON1^DICUIX2
+29 QUIT
End DoDot:1
IF 'DISUB
QUIT
IF DIOUT
QUIT
+30 IF DIOUT
SET @DILIST@(0)="0^"_DINUMBER_"^0"
DO OUT^DICL
QUIT
+31 IF DIFLAGS'["q"
DO COMMON2^DICUIX2
+32 SET DINDEX("FLIST")=DINDEX("FLIST")_"^"
+33 IF DIFLAGS'["l"
IF DIFLAGS'["h"
QUIT
+34 NEW F,F1,F2,I
SET F=DINDEX("FLIST")
+35 FOR I=1:1:DINDEX("#")
IF $GET(DINDEX(I,"GETEXT"))=0
SET F1=$GET(DINDEX(I,"FILE"))
SET F2=$GET(DINDEX(I,"FIELD"))
IF F1=DIFILEI
IF F2
Begin DoDot:1
+36 SET F1=$FIND(F,("^"_F2_"^"))
IF 'F1
QUIT
SET F1=F1-2
+37 SET $EXTRACT(F,(F1-$LENGTH(F2)),F1)=""
QUIT
End DoDot:1
+38 SET DINDEX("FLISTD")=F
QUIT
+39 ;
XREF(DIFILE,DIFLAGS,DINDEX,DIPART,DIFROM) ;
+1 ; Index is in "IX" nodes
+2 ;
X1 ; Set DINDEX for search through upright file
+1 ;
+2 IF DINDEX="#"
Begin DoDot:1
+3 SET DINDEX("#")=0
SET DINDEX(1,"FILE")=DIFILE
SET DINDEX(1,"ROOT")=DIFILE(DIFILE)
SET DINDEX(1,"TYPE")="N"
+4 NEW X
SET X=$SELECT($GET(DIFROM(1)):DIFROM(1),DIPART(1):DIPART(1),1:$GET(DIFROM("IEN")))
+5 SET (DIFROM,DIFROM(1))=X
IF X
SET DIFROM("IEN")=X
+6 IF DIFLAGS["l"!(DIFLAGS["h")
SET DINDEX("FLISTD")=""
+7 IF DIFLAGS'["q"
DO COMMON2^DICUIX2
QUIT
End DoDot:1
QUIT
+8 SET DINDEX("#")=1
SET DINDEX("IXTYPE")="R"
+9 SET DINDEX(1,"FILE")=$ORDER(^DD(DIFILE,0,"IX",DINDEX,""))
+10 ;
X2 ; Build DINDEX for index in IX nodes.
+1 ;
+2 SET DIOUT=0
SET DILENGTH=30
+3 SET DINDEX(1,"FIELD")=""
+4 IF DINDEX(1,"FILE")
SET DINDEX(1,"FIELD")=$ORDER(^DD(DIFILE,0,"IX",DINDEX,DINDEX(1,"FILE"),""))
+5 IF DINDEX(1,"FIELD")=""
IF DINDEX="B"
Begin DoDot:1
+6 SET DINDEX(1,"FILE")=DIFILE
+7 SET DINDEX(1,"FIELD")=.01
QUIT
End DoDot:1
+8 IF DIFLAGS[3
IF DINDEX="B"
IF '$DATA(@DIFILE(DIFILE)@("B"))
Begin DoDot:1
+9 DO TMPB^DICUIX1(.DITEMP,DIFILE)
+10 SET DIFILE(DIFILE,"NO B")=DITEMP
QUIT
End DoDot:1
+11 IF DIFLAGS["l"
SET DINDEX(1,"PROMPT")=""
+12 IF DINDEX(1,"FILE")
IF DINDEX(1,"FIELD")
Begin DoDot:1
+13 IF DIFLAGS["l"
SET DINDEX(1,"PROMPT")=$PIECE($GET(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0)),U)
+14 NEW I,X,Y
+15 FOR I=0:0
SET I=$ORDER(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),1,I))
IF 'I
QUIT
SET X=$GET(^(I,0))
IF $PIECE(X,U,2)=DINDEX
SET Y=$GET(^(1))
Begin DoDot:2
+16 SET X=$EXTRACT($PIECE(X,U,3),1,2)
+17 SET DINDEX("IXTYPE")=$SELECT(X="":"R",X="KW":"K",X="SO":"S",(X="TR")!(X="BU"):"*",X]"":X,1:"R")
+18 IF "KSMU"[DINDEX("IXTYPE")
SET DIGET=2
+19 SET DILENGTH=+$PIECE(Y,"$E(X,1,",2)
+20 ;!(DILENGTH>100)
IF 'DILENGTH
SET DILENGTH=30
QUIT
End DoDot:2
QUIT
+21 QUIT
End DoDot:1
IF DINDEX("IXTYPE")="*"
KILL DINDEX
SET DINDEX=""
QUIT
+22 IF $GET(DIFROM(2))
SET DIFROM("IEN")=DIFROM(2)
+23 SET DISUB=1
SET DIWAY=1
SET DIOUT=0
+24 NEW I,X,Y
+25 DO COMMON1^DICUIX2
+26 IF DIOUT
SET @DILIST@(0)="0^"_DINUMBER_"^0"
DO OUT^DICL
QUIT
+27 IF DIFLAGS'["q"
DO COMMON2^DICUIX2
+28 SET DINDEX("FLIST")=DINDEX("FLIST")_"^"
+29 IF DIFLAGS["l"!(DIFLAGS["h")
Begin DoDot:1
+30 IF DIGET=2
SET DINDEX("FLISTD")="^^"
QUIT
+31 SET DINDEX("FLISTD")=DINDEX("FLIST")
QUIT
End DoDot:1
+32 SET DITEMP=$GET(DIFILE(DIFILE,"NO B"))
IF DITEMP]""
DO BLDB^DICUIX1(DIFILE(DIFILE),DITEMP)
+33 QUIT
+34 ;
+35 ;
