- 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 ;
