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

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

initial load of WorldVistAEHR
File size: 6.8 KB
Line 
1DIDU ;SEA/TOAD-VA FileMan: DD Tools, External Format ;6/15/00 13:29
2 ;;22.0;VA FileMan;**31,48**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;11960;7754722;5858;
5 ;
6EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIMSGA) ;
7 ;
8 ; convert a value from internal to external format
9 ; used all over lookup routines
10 ;
11XTRNLX ;
12 ;
13 ; support for documented entry point $$EXTERNAL^DILFD
14 ; branch from DILFD or DIQGU
15 ;
16E1 ; set up DBS environment variables
17 ;
18 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
19 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
20 N DICLERR S DICLERR=$G(DIERR) K DIERR
21 ;
22E2 ; handle bad input variables
23 ;
24 I $G(DINTERNL)="" Q ""
25 S DIMSGA=$G(DIMSGA)
26 S DIFLAGS=$G(DIFLAGS)
27 I DIFLAGS'?.1(1"F",1"L",1"U",1"i",1"h") D ERR(DIMSGA,301,"","","",DIFLAGS) Q ""
28 I $G(DIFIELD)'>0 D ERR(DIMSGA,202,"","","","FIELD") Q ""
29 ;
30E3 ; get field definition and type, handle bad file or field
31 ;
32 I $G(DIFILE)<0 D ERR(DIMSGA,202,"","","","FILE") Q ""
33 N DINODE S DINODE=$G(^DD(DIFILE,DIFIELD,0))
34 I DINODE="" D Q ""
35 . I '$D(^DD(DIFILE)) D ERR(DIMSGA,401,DIFILE)
36 . E D ERR(DIMSGA,501,DIFILE,"",DIFIELD,DIFIELD)
37 N DITYPE S DITYPE=$P(DINODE,U,2)
38 ;
39E4 ; initialize loop control, transform code, pointer chain window,
40 ; pointer file info, and resolved value variables
41 ;
42 N DICHAIN,DIDONE,DIOUT S (DICHAIN,DIDONE,DIOUT)=0
43 N DIXFORM S DIXFORM=""
44 N DINEXT,DIPREV,DIPREVF S (DINEXT,DIPREV,DIPREVF)=""
45 N DIEN,DIHEAD,DIROOT S DIEN=""
46 N DIEXTRNL S DIEXTRNL=""
47 ;
48E5 ; handle output transforms (see docs for effects of flags)
49 ; under right conditions, execute output transform on value & quit
50 ;
51 F D I DIDONE!$G(DIERR)!DIOUT Q
52 . I DIFLAGS["U",DIXFORM'="",DITYPE'["P",DITYPE'["V" S DITYPE=DITYPE_"O"
53 . I DITYPE["O",DIFLAGS'["i",DIFLAGS'["h" D I DIDONE!$G(DIERR) Q
54 . . I DIFLAGS["F",DICHAIN Q
55 . . I DIFLAGS["L",DITYPE["P"!(DITYPE["V") Q
56 . . I DIXFORM=""!(DIFLAGS'["U") S DIXFORM=$G(^DD(DIFILE,DIFIELD,2))
57 . . I DIXFORM="" Q
58 . . I DIFLAGS["U",DITYPE["P"!(DITYPE["V") Q
59 . . N Y S Y=DINTERNL X DIXFORM
60 . . I $G(DIERR) D ERR^DICF4(120,DIFILE,DIEN,"","Output Transform") Q
61 . . S DIEXTRNL=Y,DIDONE=1
62 .
63E6 . ; continue with loop only for pointers or variable pointers
64 .
65 . I DITYPE S DIOUT=1 Q
66 . I DITYPE'["P",DITYPE'["V" S DIOUT=1 Q
67 .
68E7 . ; if the value's not numeric, it's not valid; note that throughout
69 . ; module we return two different errors depending on whether the
70 . ; value passed in is bad, or one found in the pointer chain is
71 .
72 . I 'DINTERNL D Q
73 . . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,"pointer") Q
74 . . D ERR(DIMSGA,630,DIFILE,"",DIFIELD,DIEN,DINTERNL,"pointer")
75 .
76E8 . ; get pointed to file's root and #
77 .
78 . I DITYPE["P" S DIROOT=$P(DINODE,U,3),DINEXT=+$P($P(DINODE,U,2),"P",2) D Q:$G(DIERR)
79 . . I DIROOT="DIC(.2," S DINEXT=.2
80 . . I 'DINEXT!(DIROOT="") D ERR(DIMSGA,537,DIFILE,,DIFIELD)
81 . . Q
82 . I DITYPE["V" S DIROOT=$P(DINTERNL,";",2),DINEXT="" D Q:$G(DIERR)
83 . . I DIROOT="" D ERR(DIMSGA,348,,,,DINTERNL) Q
84 . . S DIHEAD=$G(@(U_DIROOT_"0)"))
85 . . I DIHEAD="" D Q
86 . . . D HEADER(DIFILE,DIEN,DIFIELD,DITYPE,DICHAIN,DINTERNL,DINEXT)
87 . . S DINEXT=+$P(DIHEAD,U,2) I 'DINEXT D Q
88 . . . D ERR(DIMSGA,404,"","","",$$CREF^DILF(U_DIROOT))
89 .
90E9 . ; ensure pointed to data file exists, and advance file #s
91 .
92 . I '$D(@(U_DIROOT_"+DINTERNL)")) D Q
93 . . N DI S DI="pointer to File #"
94 . . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,DI_DINEXT) Q
95 . . D ERR(DIMSGA,630,DIFILE,DIFIELD,"",DIEN,DINTERNL,DI_DINEXT)
96 . S DIPREV=DIFILE,DIFILE=DINEXT
97 .
98E10 . ; advance pointer value, file characteristics, & pointer window
99 . ; ensure pointed to record exists, & its .01 has a DD
100 . ; set flag that we are now in the pointer chain
101 .
102 . S DIEN=+DINTERNL
103 . S DINTERNL=$P($G(^(DIEN,0)),U) ;***** Naked *****
104 . I DINTERNL="" D ERR(DIMSGA,603,DIFILE,"",.01,DIEN) Q
105 . S DINODE=$G(^DD(DIFILE,.01,0))
106 . S DITYPE=$P(DINODE,U,2)
107 . I DITYPE="" D ERR(DIMSGA,510,DIFILE,"",.01) Q
108 . S DIPREVF=DIFIELD,DIFIELD=.01
109 . S DICHAIN=1
110 . S:DIFILE=.2 DIDONE=1 Q
111 ;
112E11 ; exit if we executed an output transform or ran into an error
113 ;
114 ; Special "i" flag returns internal value at end of pointer chain
115 I DIFLAGS["i" Q DINTERNL
116 I DIFILE=.2 Q DINTERNL
117 I DIDONE Q DIEXTRNL
118 I $G(DIERR) Q ""
119 ;
120E12 ; handle illegal data types (pointers, word processings, and multiples)
121 ;
122 I DITYPE["C" D ERRPTR("Computed") Q ""
123 I DITYPE["W" D ERRPTR("Word Processing") Q ""
124 I DITYPE S DITYPE=$P($G(^DD(+DITYPE,.01,0)),U,2) D Q ""
125 . I DITYPE["W" D ERRPTR("Word Processing") Q
126 . D ERRPTR("Multiple") Q
127 ;
128E13 ; handle sets of codes
129 ;
130 I DITYPE["S" D Q DIEXTRNL
131 . N DICODES S DICODES=";"_$P(DINODE,U,3)
132 . N DISTART S DISTART=$F(DICODES,";"_DINTERNL_":")
133 . I 'DISTART S DIEXTRNL="" D Q
134 . . I 'DICHAIN D ERR(DIMSGA,730,DIFILE,"",DIFIELD,DINTERNL,"code") Q
135 . . D ERR(DIMSGA,630,DIFILE,DIFIELD,"",DIEN,DINTERNL,"code")
136 . S DIEXTRNL=$P($E(DICODES,DISTART,$L(DICODES)),";")
137 ;
138E14 ; handle dates, and return all others as they are
139 ;
140 I DITYPE["D",DINTERNL D Q DIEXTRNL
141 . S DIEXTRNL=$$FMTE^DILIBF(DINTERNL,"1U")
142 . I DIEXTRNL'="" Q
143 . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,"date") Q
144 . D ERR(DIMSGA,630,DIFILE,"",DIFIELD,DIEN,DINTERNL,"date")
145 I DICLERR'=""!$G(DIERR) D
146 . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
147 Q DINTERNL
148 ;
149HEADER(DIFILE,DIEN,DIFIELD,DITYPE,DICHAIN,DINTERNL,DINEXT) ;
150 ;
151 ; pick a header error and log it
152 ; EXTERNAL
153 ;
154 I DITYPE["P" D ; pointer
155 . I 'DINEXT!'$D(^DD(DINEXT)) D ERR(DIMSGA,537,DIFILE,"",DIFIELD) Q
156 . D ERR(DIMSGA,403,DINEXT)
157 ;
158 E D ; variable pointer
159 . I DICHAIN D ERR(DIMSGA,648,DIFILE,"",DIFIELD,DIEN,DINTERNL) Q
160 . D ERR(DIMSGA,348,"","","",DINTERNL)
161 Q
162 ;
163ERR(DIMSGA,DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
164 ;
165 ; error logging procedure
166 ; EXTERNAL
167 ;
168 N DIPE,DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
169 D BLD^DIALOG(DIERN,.DIPE,.DIPE,DIMSGA,"F")
170 S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
171 Q
172 ;
173ERRPTR(DITYPE) ;
174 ;
175 ; error logging shell for errors 520 & 537
176 ; EXTERNAL
177 ;
178 I DICHAIN D ERR(DIMSGA,537,DIPREV,"",DIPREVF) Q
179 D ERR(DIMSGA,520,DIFILE,"",DIFIELD,DITYPE)
180 Q
181 ;
182 ; 202 The input parameter that identifies the |1
183 ; 301 The passed flag(s) '|1|' are unknown or in
184 ; 330 The value '|1|' is not a valid |2|.
185 ; 348 The passed value '|1|' points to a file th
186 ; 401 File #|FILE| does not exist.
187 ; 403 File #|FILE| lacks a Header Node.
188 ; 404 The File Header node of the file stored at
189 ; 501 File #|FILE| does not contain a field |1|.
190 ; 510 The data type for Field #|FIELD| in File #
191 ; 520 A |1| field cannot be processed by this ut
192 ; 537 Field #|FIELD| in File #|FILE| has a corru
193 ; 603 Entry #|1| in File #|FILE| lacks the requi
194 ; 630 In Entry #|1| of File #|FILE|, the value '
195 ; 648 In Entry #|1| of File #|FILE|, the value '
196 ; 730 The value '|1|' is not a valid |2| accordi
197 ;
Note: See TracBrowser for help on using the repository browser.