DICUIX ;SEA/TOAD,SF/TKW - FileMan: Lookup Tools, Indexes ;24SEP2016
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
;;GFT;**20,28,67,165,1035,1041**
;
;
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]""
EGP . . I $P(DINODE,U,3),$P(DINODE,U,4) S X=$$LABEL^DIALOGZ($P(DINODE,U,3),$P(DINODE,U,4)) ;**
. . 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) ;TRANSFORM FOR LOOKUP
. . 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 ;TRANSFORM FOR DISPLAY
. . I "KSMU"[DINDEX("IXTYPE") S DIGET=2
. . Q
. S DILENGTH=$P(DINODE,U,5) I 'DILENGTH S DILENGTH=30 ;!(DILENGTH>100) ;GETS THE LENGTH FROM THE DEFINITION OF THE INDEX
. 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
EGP2 . I DIFLAGS["l" S DINDEX(1,"PROMPT")=$$LABEL^DIALOGZ(DINDEX(1,"FILE"),DINDEX(1,"FIELD")) ;** FIELD LABEL
. N I,X,Y,DIXFILE,DIXFIELD S DIXFILE=DINDEX(1,"FILE"),DIXFIELD=DINDEX(1,"FIELD")
. 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") ;WHAT KIND OF CROSS-REF IS IT?
. . I "KSMU"[DINDEX("IXTYPE") S DIGET=2
. . S DILENGTH=+$P(Y,"$E(X,1,",2)
. . S:'DILENGTH DILENGTH=30 ;!(DILENGTH>100)
. . S X=$P($P(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0),U,2),"t",2) I X,$G(^DI(.81,+X,201,2,31))]"" D ;V 23.0: EXTENDED DATA TYPE INPUT TRANSFORM
...S DINDEX(1,"TRANEX","EXTENDED")=^(31)
...S DINDEX(1,"TRANEX")="N DIPA,DIQUIET S DIQUIET=1 D DIPA^DIETLIBF("_DIXFILE_","_DIXFIELD_") X DINDEX(1,""TRANEX"",""EXTENDED"") I '$D(X) S X="""""
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
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICUIX 5219 printed Apr 09, 2024@21:55:51 Page 2
DICUIX ;SEA/TOAD,SF/TKW - FileMan: Lookup Tools, Indexes ;24SEP2016
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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 ;;GFT;**20,28,67,165,1035,1041**
+7 ;
+8 ;
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
EGP ;**
IF $PIECE(DINODE,U,3)
IF $PIECE(DINODE,U,4)
SET X=$$LABEL^DIALOGZ($PIECE(DINODE,U,3),$PIECE(DINODE,U,4))
+1 QUIT
End DoDot:2
SET DINDEX(DISUB,"PROMPT")=X
+2 SET DINDEX(DISUB,"FIELD")=$PIECE(DINODE,U,4)
+3 SET DINDEX(DISUB,"FILE")=$PIECE(DINODE,U,3)
+4 IF $PIECE(DINODE,U,2)["C"!(DINDEX(DISUB,"FILE")="")
SET DINDEX(DISUB,"FIELD")=""
+5 IF DINDEX(DISUB,"FILE")
IF DINDEX(DISUB,"FIELD")
Begin DoDot:2
+6 ;TRANSFORM FOR LOOKUP
IF $GET(^DD("IX",DIXIEN,11.1,S,4))]""
SET DINDEX(DISUB,"TRANCODE")=^(4)
+7 IF $GET(^DD("IX",DIXIEN,11.1,S,2))]""
Begin DoDot:3
+8 IF $GET(^DD("IX",DIXIEN,11.1,S,3))=""
SET DIGET=0
QUIT
+9 ;TRANSFORM FOR DISPLAY
SET DINDEX(DISUB,"TRANOUT")=^DD("IX",DIXIEN,11.1,S,3)
SET DIGET=3
QUIT
End DoDot:3
+10 IF "KSMU"[DINDEX("IXTYPE")
SET DIGET=2
+11 QUIT
End DoDot:2
+12 ;!(DILENGTH>100) ;GETS THE LENGTH FROM THE DEFINITION OF THE INDEX
SET DILENGTH=$PIECE(DINODE,U,5)
IF 'DILENGTH
SET DILENGTH=30
+13 SET DIWAY=$SELECT($PIECE(DINODE,U,7)="B":-1,1:1)
+14 DO COMMON1^DICUIX2
+15 QUIT
End DoDot:1
if 'DISUB
QUIT
if DIOUT
QUIT
+16 IF DIOUT
SET @DILIST@(0)="0^"_DINUMBER_"^0"
DO OUT^DICL
QUIT
+17 if DIFLAGS'["q"
DO COMMON2^DICUIX2
+18 SET DINDEX("FLIST")=DINDEX("FLIST")_"^"
+19 IF DIFLAGS'["l"
IF DIFLAGS'["h"
QUIT
+20 NEW F,F1,F2,I
SET F=DINDEX("FLIST")
+21 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
+22 SET F1=$FIND(F,("^"_F2_"^"))
if 'F1
QUIT
SET F1=F1-2
+23 SET $EXTRACT(F,(F1-$LENGTH(F2)),F1)=""
QUIT
End DoDot:1
+24 SET DINDEX("FLISTD")=F
QUIT
+25 ;
+26 ;
+27 ;
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
EGP2 ;** FIELD LABEL
IF DIFLAGS["l"
SET DINDEX(1,"PROMPT")=$$LABEL^DIALOGZ(DINDEX(1,"FILE"),DINDEX(1,"FIELD"))
+1 NEW I,X,Y,DIXFILE,DIXFIELD
SET DIXFILE=DINDEX(1,"FILE")
SET DIXFIELD=DINDEX(1,"FIELD")
+2 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
+3 SET X=$EXTRACT($PIECE(X,U,3),1,2)
+4 ;WHAT KIND OF CROSS-REF IS IT?
SET DINDEX("IXTYPE")=$SELECT(X="":"R",X="KW":"K",X="SO":"S",(X="TR")!(X="BU"):"*",X]"":X,1:"R")
+5 IF "KSMU"[DINDEX("IXTYPE")
SET DIGET=2
+6 SET DILENGTH=+$PIECE(Y,"$E(X,1,",2)
+7 ;!(DILENGTH>100)
if 'DILENGTH
SET DILENGTH=30
+8 ;V 23.0: EXTENDED DATA TYPE INPUT TRANSFORM
SET X=$PIECE($PIECE(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0),U,2),"t",2)
IF X
IF $GET(^DI(.81,+X,201,2,31))]""
Begin DoDot:3
+9 SET DINDEX(1,"TRANEX","EXTENDED")=^(31)
+10 SET DINDEX(1,"TRANEX")="N DIPA,DIQUIET S DIQUIET=1 D DIPA^DIETLIBF("_DIXFILE_","_DIXFIELD_") X DINDEX(1,""TRANEX"",""EXTENDED"") I '$D(X) S X="""""
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
IF DINDEX("IXTYPE")="*"
KILL DINDEX
SET DINDEX=""
QUIT
+11 IF $GET(DIFROM(2))
SET DIFROM("IEN")=DIFROM(2)
+12 SET DISUB=1
SET DIWAY=1
SET DIOUT=0
+13 NEW I,X,Y
+14 DO COMMON1^DICUIX2
+15 IF DIOUT
SET @DILIST@(0)="0^"_DINUMBER_"^0"
DO OUT^DICL
QUIT
+16 if DIFLAGS'["q"
DO COMMON2^DICUIX2
+17 SET DINDEX("FLIST")=DINDEX("FLIST")_"^"
+18 IF DIFLAGS["l"!(DIFLAGS["h")
Begin DoDot:1
+19 IF DIGET=2
SET DINDEX("FLISTD")="^^"
QUIT
+20 SET DINDEX("FLISTD")=DINDEX("FLIST")
QUIT
End DoDot:1
+21 SET DITEMP=$GET(DIFILE(DIFILE,"NO B"))
IF DITEMP]""
DO BLDB^DICUIX1(DIFILE(DIFILE),DITEMP)
+22 QUIT
+23 ;
+24 ;
