- 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 Feb 19, 2025@00:12:57 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 ;