source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICUIX.m@ 789

Last change on this file since 789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.2 KB
Line 
1DICUIX ;SEA/TOAD,SF/TKW-FileMan: Lookup Tools, Indexes ;11:18 AM 7 Nov 2000
2 ;;22.0;VA FileMan;**20,28,67**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5INDEX(DIFILE,DIFLAGS,DINDEX,DIFROM,DIPART,DINUMBER,DISCREEN,DILIST,DIOUT) ;
6 ;
7 ; build DINDEX array data for index
8 ;
9I1 ; try to find Index in Index file
10 ;
11 N DICODE,DIGET,DILENGTH,DINODE,DISUB,DITEMP,DITEMP2,DITO,DITOIEN,DITYPE,DIWAY,DIXIEN
12 S DINDEX("FLIST")="",DINDEX("AT")=1,DIFROM("IEN")=+$G(DIFROM("IEN")),DIXIEN="",DIGET=1
13 S:DINDEX'="#" DIXIEN=$O(^DD("IX","BB",DIFILE,DINDEX,""))
14 I 'DIXIEN D XREF(.DIFILE,.DIFLAGS,.DINDEX,.DIPART,.DIFROM) Q
15 ;
16I2 ; in Index file, build list of subscript data
17 ;
18 S DINODE=^DD("IX",DIXIEN,0)
19 S DINDEX("IXTYPE")=$P(DINODE,U,4) S:DIFLAGS["4" DINDEX("IXFILE")=DIXIEN
20 S DINDEX("#")=0
21 S DISUB=$O(^DD("IX",DIXIEN,11.1,"AC","Z"),-1)
22 I $G(DIFROM(DISUB+1)) M DIFROM("IEN")=DIFROM(DISUB+1)
23 S (DISUB,DIOUT)=0 N S
24 F D Q:'DISUB Q:DIOUT
25 . S DISUB=$O(^DD("IX",DIXIEN,11.1,"AC",DISUB)) Q:'DISUB S S=$O(^(DISUB,0)) Q:'S
26 . S DINDEX("#")=DISUB,DIGET=1
27 . S DINODE=$G(^DD("IX",DIXIEN,11.1,S,0))
28 . I DIFLAGS["l" N X D S DINDEX(DISUB,"PROMPT")=X
29 . . S X=$P(DINODE,U,8) Q:X]""
30 . . I $P(DINODE,U,3),$P(DINODE,U,4) S X=$P($G(^DD($P(DINODE,U,3),$P(DINODE,U,4),0)),U)
31 . . Q
32 . S DINDEX(DISUB,"FIELD")=$P(DINODE,U,4)
33 . S DINDEX(DISUB,"FILE")=$P(DINODE,U,3)
34 . I $P(DINODE,U,2)["C"!(DINDEX(DISUB,"FILE")="") S DINDEX(DISUB,"FIELD")=""
35 . I DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD") D
36 . . I $G(^DD("IX",DIXIEN,11.1,S,4))]"" S DINDEX(DISUB,"TRANCODE")=^(4)
37 . . I $G(^DD("IX",DIXIEN,11.1,S,2))]"" D
38 . . . I $G(^DD("IX",DIXIEN,11.1,S,3))="" S DIGET=0 Q
39 . . . S DINDEX(DISUB,"TRANOUT")=^DD("IX",DIXIEN,11.1,S,3),DIGET=3 Q
40 . . I "KSMU"[DINDEX("IXTYPE") S DIGET=2
41 . . Q
42 . S DILENGTH=$P(DINODE,U,5) I 'DILENGTH!(DILENGTH>100) S DILENGTH=30
43 . S DIWAY=$S($P(DINODE,U,7)="B":-1,1:1)
44 . D COMMON1^DICUIX2
45 . Q
46 I DIOUT S @DILIST@(0)="0^"_DINUMBER_"^0" D OUT^DICL Q
47 D:DIFLAGS'["q" COMMON2^DICUIX2
48 S DINDEX("FLIST")=DINDEX("FLIST")_"^"
49 I DIFLAGS'["l",DIFLAGS'["h" Q
50 N F,F1,F2,I S F=DINDEX("FLIST")
51 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
52 . S F1=$F(F,("^"_F2_"^")) Q:'F1 S F1=F1-2
53 . S $E(F,(F1-$L(F2)),F1)="" Q
54 S DINDEX("FLISTD")=F Q
55 ;
56XREF(DIFILE,DIFLAGS,DINDEX,DIPART,DIFROM) ;
57 ; Index is in "IX" nodes
58 ;
59X1 ; Set DINDEX for search through upright file
60 ;
61 I DINDEX="#" D Q
62 . S DINDEX("#")=0,DINDEX(1,"FILE")=DIFILE,DINDEX(1,"ROOT")=DIFILE(DIFILE),DINDEX(1,"TYPE")="N"
63 . N X S X=$S($G(DIFROM(1)):DIFROM(1),DIPART(1):DIPART(1),1:$G(DIFROM("IEN")))
64 . S (DIFROM,DIFROM(1))=X S:X DIFROM("IEN")=X
65 . I DIFLAGS["l"!(DIFLAGS["h") S DINDEX("FLISTD")=""
66 . D:DIFLAGS'["q" COMMON2^DICUIX2 Q
67 S DINDEX("#")=1,DINDEX("IXTYPE")="R"
68 S DINDEX(1,"FILE")=$O(^DD(DIFILE,0,"IX",DINDEX,""))
69 ;
70X2 ; Build DINDEX for index in IX nodes.
71 ;
72 S DIOUT=0,DILENGTH=30
73 S DINDEX(1,"FIELD")=""
74 I DINDEX(1,"FILE") S DINDEX(1,"FIELD")=$O(^DD(DIFILE,0,"IX",DINDEX,DINDEX(1,"FILE"),""))
75 I DINDEX(1,"FIELD")="",DINDEX="B" D
76 . S DINDEX(1,"FILE")=DIFILE
77 . S DINDEX(1,"FIELD")=.01 Q
78 I DIFLAGS[3,DINDEX="B",'$D(@DIFILE(DIFILE)@("B")) D
79 . D TMPB^DICUIX1(.DITEMP,DIFILE)
80 . S DIFILE(DIFILE,"NO B")=DITEMP Q
81 I DIFLAGS["l" S DINDEX(1,"PROMPT")=""
82 I DINDEX(1,"FILE"),DINDEX(1,"FIELD") D I DINDEX("IXTYPE")="*" K DINDEX S DINDEX="" Q
83 . I DIFLAGS["l" S DINDEX(1,"PROMPT")=$P($G(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0)),U)
84 . N I,X,Y
85 . 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
86 . . S X=$E($P(X,U,3),1,2)
87 . . S DINDEX("IXTYPE")=$S(X="":"R",X="KW":"K",X="SO":"S",(X="TR")!(X="BU"):"*",X]"":X,1:"R")
88 . . I "KSMU"[DINDEX("IXTYPE") S DIGET=2
89 . . S DILENGTH=+$P(Y,"$E(X,1,",2)
90 . . S:'DILENGTH!(DILENGTH>100) DILENGTH=30 Q
91 . Q
92 I $G(DIFROM(2)) S DIFROM("IEN")=DIFROM(2)
93 S DISUB=1,DIWAY=1,DIOUT=0
94 N I,X,Y
95 D COMMON1^DICUIX2
96 I DIOUT S @DILIST@(0)="0^"_DINUMBER_"^0" D OUT^DICL Q
97 D:DIFLAGS'["q" COMMON2^DICUIX2
98 S DINDEX("FLIST")=DINDEX("FLIST")_"^"
99 I DIFLAGS["l"!(DIFLAGS["h") D
100 . I DIGET=2 S DINDEX("FLISTD")="^^" Q
101 . S DINDEX("FLISTD")=DINDEX("FLIST") Q
102 S DITEMP=$G(DIFILE(DIFILE,"NO B")) I DITEMP]"" D BLDB^DICUIX1(DIFILE(DIFILE),DITEMP)
103 Q
104 ;
105 ;
Note: See TracBrowser for help on using the repository browser.