source: FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICU1.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 5.2 KB
Line 
1DICU1 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Get IDs & Index ;9/9/98 09:02
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5IDENTS(DIFLAGS,DIFILE,DIDS,DIWRITE,DIDENT,DINDEX) ;
6 ; get definition of fields to return with each entry
7 ;
8ID1 ; prepare to build output processor:
9 ;
10 S DIDS=";"_DIDS_";"
11 I DIDS[";@;" S DIDS("@")=""
12 E S:DIDS'[";-WID;" DIDS("WID")="" S:DIDS=";;" DIDS("FID")=""
13 N DICRSR,DICOUNT S (DICRSR,DICOUNT)=0
14 I DIFLAGS["P" S DICRSR=1,DIDENT(-3)="IEN"
15 N DIFORMAT,DIDEFALT S DIDEFALT=$S(DIFLAGS["I":"I",1:"E")
16 ;
17ID1A ; for Lister: add indexed fields to DIDENT array (to build 1 nodes)
18 ;
19 I DIFLAGS[3,DIFLAGS'["S",DIDS'[";-IX",'$D(DIDS("@")) D
20 . S DIDENT=-2,DIDENT(-2)=1
21 . D THROW^DICU11(DIFLAGS,.DIDENT,.DIDS,.DICRSR,.DICOUNT,DIDEFALT,.DINDEX)
22 . S DIDENT=0
23 ;
24ID2 ; decide whether to auto-include the .01 in the field list
25 ; will come out in 1 node for Lister, in "ID" nodes for Finder
26 ;
27 N DIUSEKEY S (DIUSEKEY,DIDENT)=0
28 I '$D(DIDS("@")),DIDS'[";-.01;",DIFLAGS'["S" D
29 . I DIFLAGS[4 S DIUSEKEY="1F" Q
30 . I DIDS[";.01;"!(DIDS[";.01E") Q
31 . S DIUSEKEY=1 N DISUB F DISUB=1:1:DINDEX("#") D Q:'DIUSEKEY
32 . . Q:DINDEX(DISUB,"FIELD")'=.01
33 . . S DIUSEKEY=DINDEX(DISUB,"FILE")'=DIFILE
34 . Q
35 I DIUSEKEY S DIDENT(-2)=1,DIDENT=.01
36 N DICODE,DIDEF,DIEFROM,DIETO,DINODE,DIPIECE,DISTORE,DITYPE,DIFRMAT2
37 N DILENGTH,DIOUTI S DILENGTH=$L(DIDS,";"),DIOUTI=0
38 ;
39ID3 ; Process auto-included .01 field (if included) on first pass,
40 ; Start loop to process each field from DIFIELDS parameter
41 ; and Identifiers.
42 ;
43 F D Q:$G(DIERR)!DIOUTI
44 . S DIFORMAT=""
45 . I DIUSEKEY D Q
46 . . D BLD S DIUSEKEY=$S(DIUSEKEY="1F":"F",1:0)
47 . . S:DIDENT=-2 DIDENT=.01 Q
48 . D Q:'DIDENT
49 . . S DIUSEKEY=0
50 . . ; Find next Identifier
51 . . I $D(DIDS("FID")) D Q
52 . . . S DIDENT=$O(^DD(DIFILE,0,"ID",DIDENT))
53 . . . I 'DIDENT K DIFRMAT2
54 . . . I DIDENT="" S:DIDS=";;" DIOUTI=1 K DIDS("FID")
55 . .
56ID4 . . ; Find next field in DIFIELDS input parameter.
57 . .
58 . . S DICOUNT=DICOUNT+1
59 . . S DIDENT=$P(DIDS,";",DICOUNT)
60 . . I DIDENT="",DICOUNT'<DILENGTH S DIOUTI=1
61 . .
62ID4A . . ; process IX specifier
63 . .
64 . . I DIDENT["IX" D Q
65 . . . I $$BADIX(DIDENT) D ERR202 Q
66 . . . Q:DIDS[";-IX;"
67 . . . D THROW^DICU11(DIFLAGS,.DIDENT,.DIDS,.DICRSR,.DICOUNT,DIDEFALT,.DINDEX)
68 . .
69ID4B . . ; process FID, WID, and @ specifiers
70 . .
71 . . I DIDENT["FID" D S DIDENT="" Q
72 . . . Q:DIDENT="-FID"!(DIDS[";-FID;")
73 . . . D GETFORM^DICU11(.DIDENT,.DIFRMAT2,.DIDS,.DICOUNT)
74 . . . S DIDS("FID")=1 Q
75 . . I DIDENT["WID" D S DIDENT="" Q
76 . . . I DIDENT'="WID",DIDENT'="-WID" D ERR202 Q
77 . . . Q:DIDENT="-WID"!(DIDS[";-WID;")
78 . . . D WRITEID^DICU11(DIFILE,.DIDENT,.DICRSR) K DIDS("WID") Q
79 . . I DIDENT["@" D:DIDENT'="@" ERR202 Q
80 . . I 'DIDENT D:DIDENT'="" ERR202 Q
81 . .
82ID4C . . ; process field # specifiers from DIFIELDS parameter
83 . .
84 . . D GETFORM^DICU11(.DIDENT,.DIFORMAT,.DIDS,.DICOUNT)
85 .
86 . ; Here we quit if field is already in the DIDENT array.
87 . I DIDS=";;",DIFLAGS[4,DIUSEKEY'="F",DIDENT=.01 Q
88 . I DIDS=";;",DIFLAGS[3,DINDEX("FLIST")[("^"_DIDENT_"^") Q
89 .
90ID5 . ; for file IDs, we skip non-display IDs
91 .
92 . N DIPLUS S DIPLUS=+DIDENT
93 . N DILAST S DILAST=$P(DIDENT,DIPLUS,2,999)
94 . I DIDENT["-" D Q
95 . . I DILAST'="" D ERR202 Q
96 . . I '$D(^DD(DIFILE,-DIPLUS)) D ERR(501,DIFILE,"","",-DIPLUS) Q
97 . E I (DILAST'?.1"E".1"I")&(DILAST'?.1"I".1"E") D ERR202 Q
98 . Q:DIDS[(";-"_DIDENT_";")
99 . I $D(DIDS("FID")) D I DINODE="W """"" Q
100 . . S DINODE=$G(^DD(DIFILE,0,"ID",DIDENT))
101 . I $G(DIFRMAT2)]"" S DIFORMAT=DIFRMAT2
102 . D BLD Q
103 ;
104ID6 ; Write Identifiers: add to output processor
105 ; ID Parameter: add ID parameter to output processor
106 ;
107 Q:$G(DIERR)
108 I $D(DIDS("WID")) D WRITEID^DICU11(DIFILE,.DIDENT,.DICRSR)
109 I DIWRITE'="" D
110 . S DIDENT="ZZZ ID" I DIFLAGS["P" S DICRSR=DICRSR+1
111 . S DIDENT(DICRSR,DIDENT,0)="N DIMSG "_DIWRITE
112 . S:DIFLAGS["P" $P(DIDENT(-3),U,DICRSR)="IDP" Q
113 Q
114 ;
115BLD ; get fetch code for value
116 D GET^DICUIX1(DIFILE,DIFILE,DIDENT,.DIDEF,.DICODE) Q:DIDEF=""!$G(DIERR)
117 I DIFORMAT="" S DIFORMAT=$S(DIUSEKEY="1F":"I",1:DIDEFALT)
118 D
119 . N DIVALUE S DIVALUE=DIDENT
120 . I DIUSEKEY'["F",$D(DIDS("FID")),DIDENT'=.01 S DIVALUE="FID("_DIVALUE_")"
121 . S:DIFORMAT="I" DIVALUE=DIVALUE_DIFORMAT
122 . I DIFLAGS["P" S $P(DIDENT(-3),U,(DICRSR+1))=DIVALUE Q
123 . Q:DIUSEKEY="1F"
124 . S DIDENT(-3,+DIDENT,DIVALUE)="" Q
125BLD1 ; set up format code and load with fetch code into DIDENT
126 N DIVALUE,DISUB S DIVALUE=DICODE,DISUB=0
127 S DITYPE=$P(DIDEF,U,2) I DITYPE'["C" D
128 . S DIVALUE=$$FORMAT^DICU11(DIDENT,DICODE,DIUSEKEY,DIFORMAT,DIDEFALT,DIFLAGS)
129 I DIUSEKEY="1F",DIDENT=.01 S DIDENT=-2,DISUB=.01
130 I DIFLAGS["P" S DICRSR=DICRSR+1
131 I DITYPE'["C" S DIDENT(DICRSR,DIDENT,DISUB,DIFORMAT)=DIVALUE Q
132 S DIDENT(DICRSR,DIDENT,0)=DIVALUE
133 S DIDENT(DICRSR,DIDENT,0,"TYPE")="C"
134 Q
135 ;
136ERR(DIERN,DIFILE,DIENS,DIFIELD,DI1) ;
137 ;
138 ; add an error to the message array
139 ; GET
140 ;
141 N DIPE
142 S DIPE("FILE")=$G(DIFILE)
143 S DIPE("IEN")=$G(DIENS)
144 S DIPE("FIELD")=$G(DIFIELD)
145 S DIPE(1)=$G(DI1)
146 D BLD^DIALOG(DIERN,.DIPE,.DIPE)
147 Q
148 ;
149ERR202 D ERR(202,"","","","FIELDS") Q
150 ;
151BADIX(DIDENT) ;
152 ;
153 N DIBAD S DIBAD=DIDENT'="IX"&(DIDENT'="-IX")&(DIDENT'?1"IX"1"E".1"I")
154 S DIBAD=DIDENT'?1"IX"1"I".1"E"&DIBAD
155 Q DIBAD
156 ;
157 ; 202 The input parameter that identifies the |1
158 ;
Note: See TracBrowser for help on using the repository browser.