source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m@ 1423

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

initial load of FOIAVistA 6/30/08 version

File size: 8.6 KB
Line 
1HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 10/19/2007 11:15
2 ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 14
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ;
6 ; Rules: if any of these rules is broken, FILE^DIE is called instead
7 ;
8 ; * Can't edit files other than 772,773
9 ; * Don't pass IENS value with multiples IENs. You can only
10 ; edit one IEN at a time!
11 ; * Only flag "S" is honored. Flag "K" is ignored. Other
12 ; flags result in FILE^DIE being called.
13 ; * Can't edit ^HLMA(IEN,90) data.
14 ; * Can't edit ^HLMA(IEN,91) data.
15 ; * Can't edit ^HL(772,IEN,"IN") data (field #200, MESSAGE TEXT)
16 ; * No checking of data performed! (Data format MUST be OK.)
17 ; * No locking of records in files 772 or 773. (Locks on queues.)
18 ;
19FILE(FLAGS,ROOT,ERR,SUB,RTN) ; FILE^DIE functional equivalent...
20 ; This call has similar parameters to FILE^DIE, but changes data
21 ; using hard sets. The first two parameters of this API are the
22 ; same as FILE^DIE. So, if any file other than 772 or 773 is being
23 ; edited, this API just passes on the FLAGS,ROOT,ERR parameters to
24 ; FILE^DIE and quits. If file 772 or 773 is being edited, the hard
25 ; set code in HLDIE772 and HLDIE773 is called.
26 ;
27 N DEBUG,FILE,HLEDITOR,LERR,IEN,X,XECMCODE
28 ;
29 S DT=$$NOW^XLFDT\1
30 ;
31 D BEGIN ; Debug call at beginning or process
32 ;
33 ; Check FILE, IEN, FIELDs passed, etc...
34 I '$$CHECKS D QUIT ;->
35 .
36 . S HLEDITOR="FILE^DIE"
37 .
38 . ; Call FILEMAN...
39 . D FILE^DIE($G(FLAGS),$G(ROOT),$G(ERR))
40 .
41 . ; Debug call made even with Fileman...
42 . D END
43 ;
44 S HLEDITOR="FILE^HLDIE"
45 ;
46 ; If this point is reached, file 772 or 773 is being edited, data
47 ; in ROOT() has been checked, and data is being hard set...
48 ;
49 ;
50 ; Make sure ERR is defined...
51 I $G(ERR)']"" N HLERR S ERR="HLERR"
52 ;
53 ; All editing occurs in this call...
54 D EDITALL(.ROOT,FILE,IEN)
55 ;
56 ; Store debug data if XTMP debug string set...
57 D END
58 ;
59 ;check if ROOT needs to be retained
60 I FLAGS'["S" K @ROOT,FLAGS
61 ;
62 Q
63 ;
64EDITALL(ROOT,FILE,IEN) ; Edit 772 or 773 by direct sets...
65 ;
66 ; FILE,IEN -- optional (parsed from ROOT())
67 ;
68 N ERRNO,FIELD,GBL,NODE,ROUTINE,TAG,VALUE,XRF
69 ;
70 S GBL=$$GBL(FILE,+IEN)
71 ;
72 ;check if .01="@" for deletion of record...
73 I $G(@ROOT@(FILE,IEN,.01))="@" D Q
74 .I FILE=773 D DEL773^HLUOPT3(+IEN) Q
75 .I FILE=772 D DEL772^HLUOPT3(+IEN)
76 ;
77 ; patch HL*1.6*122: MPI-client/server
78 ; If no data in record passed in, log an error and quit...
79 ; I '$D(@GBL) D Q ; Remember. GBL contains IEN...
80 N HLDGBL
81 F L +@GBL:10 Q:$T H 1
82 S HLDGBL=$D(@GBL)
83 L -@GBL
84 I 'HLDGBL D Q ; Remember. GBL contains IEN...
85 . S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2)
86 . S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"")
87 ;
88 ;
89 ; What routine holds the file-specific field/xref set code?
90 S ROUTINE=$S(FILE=772:"HLDIE772",FILE=773:"HLDIE773",1:"")
91 ;
92 ; Load NODEs...
93 D GETNODES(FILE,+IEN,.NODE)
94 ;
95 ; When a field is edited, the NODE(1) is changed
96 ;
97 ; Edit NODE(1), adding new values, and set XRF(XREF) nodes...
98 S FIELD=0
99 F S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD'>0 D
100 . ; VALUE = value passed in by process that is to be stored in file
101 . S VALUE=$G(@ROOT@(FILE,IEN,FIELD))
102 .
103 . ; If field should be deleted, VALUE will equal @...
104 . I VALUE="@" S VALUE=""
105 .
106 . ; Get and check tag...
107 . S TAG="F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE
108 . S TAG(1)=$T(@TAG) I TAG(1)']"" D QUIT ;->
109 . . S ERRNO=$$ERRNO(501,"No set logic for file #"_FILE_"'s field# "_FIELD,FILE,3)
110 . . S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
111 . . S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
112 .
113 . ; Call the subroutine below that is for the specific field...
114 . ; (No editing of xrefs or global data occurs in these calls.)
115 . D @("F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE)
116 ;
117 ; If no data actually changed, quit...
118 QUIT:'$D(NODE("CHG")) ;->
119 ;
120 ; patch HL*1.6*122: MPI-client/server
121 I FILE=773 D
122 . F L +^HLMA(IEN):10 Q:$T H 1
123 E D
124 . F L +^HL(772,IEN):10 Q:$T H 1
125 ;
126 ; Store changes in the global now...
127 D STORE(FILE,IEN,.NODE)
128 ;
129 ; Set xrefs to correspond to the just-stored data...
130 S XRF=""
131 F S XRF=$O(XRF(XRF)) Q:XRF']"" D
132 . D @("XRF"_XRF_U_ROUTINE)
133 ;
134 ; patch HL*1.6*122: MPI-client/server
135 I FILE=773 L -^HLMA(IEN)
136 E L -^HL(772,IEN)
137 ;
138 Q
139 ;
140GETNODES(FILE,IEN,NODE) ; Load pre-change data for each node in
141 ; NODE(node,0), and load node to be changed in NODE(node,1).
142 ; GBL -- req
143 F NODE=0,1,2,"P","S" D
144 . ; After setting, NODE(NODE,0) will equal each other.
145 . ; However, after each edited field is processed, the pieces of
146 . ; data in NODE(NODE,1) will be changed. The pre and post nodes
147 . ; then are of comparison value.
148 . S NODE(NODE,0)=$G(@GBL@(NODE)) ; Pre-change node
149 . S NODE(NODE,1)=NODE(NODE,0) ; Node that is changed
150 Q
151 ;
152STORE(FILE,IEN,NODE) ; Store changes in file...
153 N DATA,ND
154 ;
155 ; Loop thru change nodes, get changed data, and store it...
156 S ND=""
157 F S ND=$O(NODE("CHG",ND)) Q:ND']"" D
158 . S DATA=$G(NODE(ND,1))
159 . ; Even if no data no node, store it. (Will be removed by purge.)
160 . I FILE=772 S ^HL(772,+IEN,ND)=DATA
161 . I FILE=773 S ^HLMA(+IEN,ND)=DATA
162 ;
163 QUIT
164 ;
165GBL(FILE,IEN) QUIT $S(FILE=772:"^HL(772,"_+IEN_")",1:"^HLMA("_+IEN_")")
166 ;
167CHKFLD(FILE,FIELD) ; Does passed-in field exist?
168 ; Returns -- @ERR@(...) ->
169 ;
170 ; Quit if field exists...
171 QUIT:$D(^DD(+FILE,+FIELD)) 1 ;->
172 ;
173 ; Field doesn't exist. Log error...
174 S ERRNO=$$ERRNO(501,"File #"_FILE_" does not contain a field "_FIELD_".",FILE,3)
175 S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
176 S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
177 ;
178 Q ""
179 ;
180ERRNO(NUM,TXT,FILE,PNO) ; Return next ERROR number and create general data...
181 N NO
182 S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
183 S @ERR@("DIERR",NO)=NUM
184 S @ERR@("DIERR",NO,"PARAM",0)=PNO
185 S @ERR@("DIERR",NO,"PARAM","FILE")=FILE
186 S @ERR@("DIERR",NO,"TEXT",1)=TXT
187 S @ERR@("DIERR","E",NUM,NO)=""
188 Q NO
189 ;
190GENLERR(ETXT) ; Store GENERAL (and fatal) error...
191 ; ERR -- req
192 N NO
193 S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
194 S @ERR@("DIERR",NO)=999_U_ETXT ; Made up error number
195 Q
196 ;
197CHECKS() ; Check ROOT() for file and validity of data...
198 ; FLAGS, ROOT() -- req --> FILE,IEN
199 N I,OK,FIELD
200 ;
201 ;check the file & ien
202 S FILE=$O(@ROOT@(0))
203 I FILE'=772,FILE'=773 D QUIT "" ;->
204 . S IEN=$S(FILE:$O(@ROOT@(FILE,0)),1:0) ; Set for debugging
205 ;
206 ; ;shouldn't be more than 1 file!
207 QUIT:$O(@ROOT@(FILE)) "" ;->
208 ;
209 ;check the ien structure, and that only ien passed...
210 S IEN=$O(@ROOT@(FILE,0))
211 ; Structure check...
212 QUIT:$P(IEN,",")'=+IEN_"," "" ;->
213 ; Is it numeric?
214 QUIT:'(+IEN) "" ;->
215 ; Has more than one IEN been passed?
216 QUIT:($O(@ROOT@(FILE,IEN))'="") "" ;->
217 ;
218 ;check the flags. Only K and S flags allowed...
219 I $L(FLAGS) D QUIT:'OK "" ;->
220 . S OK=1
221 . F I=0:1:$L(FLAGS) I $E(FLAGS,I)'="K",$E(FLAGS,I)'="S" S OK=0
222 ;
223 ; Check for existence of FIELD in FILE's DD & if an excluded field.
224 ; (See rules for fields which cannot be updated by FILE^HLDIE.)
225 S FIELD=0,OK=1
226 F S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD="" D Q:'OK
227 . I '$$CHKFLD(FILE,FIELD) S OK=0 Q
228 . I FILE=773,FIELD\1=90 S OK=0 Q
229 . I FILE=773,FIELD\1=91 S OK=0 Q
230 . I FILE=772,FIELD=200 S OK=0 Q
231 ;
232 ; If not OK to use FILE^HLDIE, skip any further testing...
233 QUIT:'OK "" ;->
234 ;
235 ; *** WARNING ***
236 ; The following check **MUST** be removed after FILE^HLDIE is working.
237 ;
238 ; Final check for whether FILE^HLDIE should be used...
239 I $G(^XTMP("HLDIE-DEBUG","CALL"))]"" QUIT "" ;->
240 ; If this node exists and follows null, FILE^DIE will be used.
241 ; Otherwise, execution defaults to using FILE^HLDIE.
242 ;
243 Q OK
244 ;
245BEGIN ; Always call here before any ^HLDIE or ^DIE calls...
246 D DEBUG(1)
247 Q
248 ;
249END ; Always call here after all ^HLDIE or ^DIE actions...
250 D DEBUG(2)
251 Q
252 ;
253DEBUG(LOC) ; Debug presets and setup...
254 ; Most variables created here should be left around. These variables
255 ; are newed above.
256 N STORE
257 ;
258 S RTN=$G(RTN),SUB=$G(SUB)
259 ;
260 ; First-time (beginning) call setups...
261 I LOC=1 D
262 . S RTN=$S(RTN]"":RTN,1:"HLDIE")_"~"_$S(RTN="HLDIE":"FILE",1:SUB)
263 . S DEBUG=$G(^XTMP("HLDIE-DEBUG","STATUS"))
264 . S XECMCODE=$P(DEBUG,U,3)
265 ; DEBUG is always called at beginning (LOC=1) and end (LOC=2) or
266 ; FILE^HLDIE. So, set up variables only once, at beginning...
267 ;
268 ; Setup that is individual to each (1 or 2) call...
269 S STORE=$P(DEBUG,U,LOC),STORE=$S(STORE=1:1,STORE=2:2,1:"")
270 ; Some, All, or no data stored?
271 ;
272 ; If no STORE instructions, and no M code to specify STORE, quit...
273 QUIT:'STORE&($G(XECMCODE)'=1) ;->
274 ;
275 ; Call DEBUG to STORE data...
276 D DEBUG^HLDIEDBG(RTN,LOC,STORE,XECMCODE)
277 ;
278 Q
279 ;
280EOR ;HLDIE - Direct 772 & 773 Sets ; 11/18/2003 11:17
Note: See TracBrowser for help on using the repository browser.