source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENEGT.m@ 1306

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

initial load of WorldVistAEHR
File size: 9.1 KB
Line 
1DGENEGT ;ALB/KCL/RGL - Enrollment Group Threshold API's ; 11/20/03 3:39pm
2 ;;5.3;Registration;**232,451**;Aug 13, 1993
3 ;
4 ;
5LOCK(IEN) ;
6 ; Description: Used to lock the ENROLLMENT GROUP THRESHOLD record.
7 ;
8 ; Input:
9 ; IEN - internal entry number of record in the ENROLLMENT GROUP TRHESHOLD file
10 ;
11 ; Output:
12 ; Function Value: Returns 1 if the ENROLLMENT GROUP THRESHOLD record
13 ; can be locked, otherwise returns 0 on failure
14 ;
15 I $G(IEN) L +^DGEN(27.16,IEN,0):2
16 Q $T
17 ;
18 ;
19UNLOCK(IEN) ;
20 ; Description: Used to unlock the ENROLLMENT GROUP THRESHOLD record.
21 ;
22 ; Input:
23 ; IEN - internal entry number of record in the ENROLLMENT GROUP TRHESHOLD file
24 ;
25 ; Output:
26 ; None
27 ;
28 I $G(IEN) L -^DGEN(27.16,IEN,0)
29 Q
30 ;
31 ;
32FINDCUR(ENRDT) ;
33 ; Description: Used to find a record in the ENROLLMENT GROUP THRESHOLD file.
34 ;
35 ; Input: Enrollment Date (optional - if not specified, today is assumed)
36 ;
37 ; Output:
38 ; Function Value: If successful, returns internal entry number of
39 ; record in the ENROLLMENT GROUP THRESHOLD file,
40 ; otherwise returns 0 on failure
41 ;
42 N DGEGTDT,STOP,DGEGTIEN,DGEGTF
43 S DGEGTDT=$G(ENRDT)+.000001,STOP=0,DGEGTIEN=""
44 S:'$G(ENRDT) DGEGTDT=$$DT^XLFDT+DGEGTDT
45 F S DGEGTDT=$O(^DGEN(27.16,"B",DGEGTDT),-1) Q:STOP!(DGEGTDT="") D
46 .F S DGEGTIEN=$O(^(DGEGTDT,DGEGTIEN),-1) Q:DGEGTIEN=""!STOP D
47 ..S:'$P($G(^DGEN(27.16,+DGEGTIEN,0)),"^",8) STOP=DGEGTIEN
48 S DGEGTF=1
49 I $G(ENRDT),ENRDT'>DT,$$INACT(STOP) ;inactivate old EGT settings
50 Q +STOP
51 ;
52 ;
53GET(EGTIEN,DGEGT) ;
54 ; Description: Used to obtain a record in the ENROLLMENT GROUP THRESHOLD file. The values will be returned in the DGEGT() array.
55 ;
56 ; Input:
57 ; EGTIEN - internal entry number of record in the ENROLLMENT GROUP THRESHOLD file
58 ;
59 ; Output:
60 ; DGEGT - The ENROLLMENT GROUP THRESHOLD array, passed by reference
61 ;
62 ; Subscript Field
63 ; --------- ---------------------
64 ; "EFFDATE" EGT EFFECTIVE DATE
65 ; "PRIORITY" EGT PRIORITY
66 ; "SUBGRP" EGT SUBGROUP
67 ; "TYPE" EGT TYPE
68 ; "FEDDATE" FEDERAL REGISTER DATE
69 ; "ENTDATE" DATE ENTERED
70 ; "SOURCE" SOURCE OF EGT
71 ; "REMARKS" REMARKS
72 ;
73 N SUB,NODE
74 K DGEGT S DGEGT=""
75 ;
76 I '$G(EGTIEN) D Q 0
77 .F SUB="EFFDATE","PRIORITY","SUBGRP","TYPE","FEDDATE","ENTDATE","SOURCE","REMARKS" S DGEGT(SUB)=""
78 ;
79 S NODE=$G(^DGEN(27.16,EGTIEN,0))
80 S DGEGT("EFFDATE")=$P(NODE,"^")
81 S DGEGT("PRIORITY")=$P(NODE,"^",2)
82 S DGEGT("SUBGRP")=$P(NODE,"^",3)
83 S DGEGT("TYPE")=$P(NODE,"^",4)
84 S DGEGT("FEDDATE")=$P(NODE,"^",5)
85 S DGEGT("ENTDATE")=$P(NODE,"^",6)
86 S DGEGT("SOURCE")=$P(NODE,"^",7)
87 S NODE=$G(^DGEN(27.16,EGTIEN,"R"))
88 S DGEGT("REMARKS")=$P(NODE,"^")
89 ;
90 Q 1
91 ;
92 ;
93STORE(DGEGT,ERROR,CHKFLG) ;
94 ; Description: Creates a new entry in the ENROLLMENT GROUP THRESHOLD file.
95 ;
96 ; Input:
97 ; DGEGT - the ENROLLMENT GROUP THRESHOLD array, passed by reference
98 ; CHKFLG - a flag, if set to 1 means that field validation checks
99 ; were completed, 0 indicates field validation checks should
100 ; be performed (optional)
101 ;
102 ; Output:
103 ; Function Value - Returns internal entry number of record created, or 0 on failure
104 ; ERROR - if not successful, an error message is returned,
105 ; pass by reference (optional)
106 ;
107 ;
108 S ERROR=""
109 I $G(CHKFLG)'=1 Q:'$$VALID(.DGEGT,.ERROR) 0
110 ;
111 N ADD,DATA,OLDEGT,INACT
112 S OLDEGT=$$FINDCUR()
113 S DATA(.01)=DGEGT("EFFDATE")
114 S DATA(.02)=DGEGT("PRIORITY")
115 S DATA(.03)=DGEGT("SUBGRP")
116 S DATA(.04)=DGEGT("TYPE")
117 S DATA(.05)=DGEGT("FEDDATE")
118 S DATA(.06)=DGEGT("ENTDATE")
119 S DATA(.07)=DGEGT("SOURCE")
120 S DATA(25)=DGEGT("REMARKS")
121 S ADD=$$ADD^DGENDBS(27.16,,.DATA,.ERROR)
122 ;
123 ; inactivate "old" EGT settings
124 S INACT=$$INACT(ADD,.OLDEGT,.DGEGT)
125 ;
126 Q +ADD
127 ;
128 ;
129UPDATE(EGTIEN,DGEGT,ERROR) ;
130 ; Description: Updates an Enrollment Group Threshold record in the
131 ; ENROLLMENT GROUP THRESHOLD file. This function locks the Enrollment
132 ; Group Threshold record and releases the lock when the update is
133 ; complete.
134 ;
135 ; Input:
136 ; EGTIEN - internal entry number of record in the ENROLLMENT GROUP THRESHOLD file
137 ; DGEGT - the ENROLLMENT GROUP THRESHOLD array, passed by reference
138 ;
139 ; Output:
140 ; Function Value - Returns 1 if successful, otherwise 0
141 ; ERROR - if not successful, an error message is returned,
142 ; pass by reference
143 ;
144 N SUCCESS,DATA
145 S SUCCESS=1
146 S ERROR=""
147 ;
148 D ; drops out of do block if invalid condition is found
149 .I $G(EGTIEN),$D(^DGEN(27.16,EGTIEN,0))
150 .E S SUCCESS=0,ERROR="ENROLLMENT GROUP THRESHOLD RECORD NOT FOUND" Q
151 .I '$$LOCK(EGTIEN) S SUCCESS=0,ERROR="ENROLLMENT GROUP THRESHOLD RECORD IS LOCKED, CAN'T BE EDITED" Q
152 .;
153 .S DATA(.01)=DGEGT("EFFDATE")
154 .S DATA(.02)=DGEGT("PRIORITY")
155 .S DATA(.03)=DGEGT("SUBGRP")
156 .S DATA(.04)=DGEGT("TYPE")
157 .S DATA(.05)=DGEGT("FEDDATE")
158 .S DATA(.06)=DGEGT("ENTDATE")
159 .S DATA(.07)=DGEGT("SOURCE")
160 .S DATA(25)=DGEGT("REMARKS")
161 .;
162 .I '$$UPD^DGENDBS(27.16,EGTIEN,.DATA) S ERROR="FILEMAN UNABLE TO PERFORM UPDATE",SUCCESS=0 Q
163 ;
164 D UNLOCK(EGTIEN)
165 ;
166 Q SUCCESS
167 ;
168 ;
169DELETE(EGTIEN) ; Description: This function will delete a record in the ENROLLMENT GROUP THRESHOLD file.
170 ;
171 ; Input:
172 ; EGTIEN - as internal entry number of record to delete
173 ;
174 ; Outpu:
175 ; Function Value - Returns 1 if successful, otherwise 0
176 ;
177 Q:'$G(EGTIEN) 0
178 N DIK,DA
179 S DIK="^DGEN(27.16,"
180 S DA=EGTIEN
181 D ^DIK
182 Q 1
183 ;
184 ;
185VALID(DGEGT,ERROR) ;
186 ; Description: Performs validation checks on ENROLLMENT GROUP THRESHOLD record contained in the DGEGT array.
187 ;
188 ; Input:
189 ; DGEGT - the ENROLLMENT GROUP THRESHOLD array, passed by reference
190 ;
191 ; Output:
192 ; Function Value - Returns 1 if validation checks passed, 0 otherwise
193 ; ERROR - if validation checks fail, an error message is
194 ; returned, pass by reference
195 ;
196 N VALID,EXTERNAL,RESULT
197 S VALID=1
198 S ERROR=""
199 ;
200 D ; drops out of DO block if an invalid condition found
201 .;
202 .; check for required fields
203 .I $G(DGEGT("EFFDATE"))="" S VALID=0,ERROR="REQUIRED FIELD 'EGT EFFECTIVE DATE' MISSING" Q
204 .I $G(DGEGT("PRIORITY"))="" S VALID=0,ERROR="REQUIRED FIELD 'EGT PRIORITY' MISSING" Q
205 .I $G(DGEGT("TYPE"))="" S VALID=0,ERROR="REQUIRED FIELD 'EGT TYPE' MISSING" Q
206 .I $G(DGEGT("ENTDATE"))="" S VALID=0,ERROR="REQUIRED FIELD 'DATE ENTERED' MISSING" Q
207 .I $G(DGEGT("SOURCE"))="" S VALID=0,ERROR="REQUIRED FIELD 'SOURCE OF EGT' MISSING" Q
208 .;
209 .; check if field values are valid
210 .I '$$TESTVAL("EFFDATE",DGEGT("EFFDATE")) S VALID=0,ERROR="'EGT EFFECTIVE DATE' NOT VALID" Q
211 .I '$$TESTVAL("PRIORITY",DGEGT("PRIORITY")) S VALID=0,ERROR="'EGT PRIORITY' NOT VALID" Q
212 .I '$$TESTVAL("SUBGRP",DGEGT("SUBGRP")) S VALID=0,ERROR="'EGT SUBGRP' NOT VALID" Q
213 .I '$$TESTVAL("TYPE",DGEGT("TYPE")) S VALID=0,ERROR="'EGT TYPE' NOT VALID" Q
214 .I '$$TESTVAL("FEDDATE",DGEGT("FEDDATE")) S VALID=0,ERROR="'FEDERAL REGISTER DATE' NOT VALID" Q
215 .I '$$TESTVAL("ENTDATE",DGEGT("ENTDATE")) S VALID=0,ERROR="'DATE ENTERED' NOT VALID" Q
216 .I '$$TESTVAL("SOURCE",DGEGT("SOURCE")) S VALID=0,ERROR="'SOURCE OF EGT' NOT VALID" Q
217 .I ($G(DGEGT("REMARKS"))'="")&($L($G(DGEGT("REMARKS")))<3)!($L($G(DGEGT("REMARKS")))>80) S VALID=0,ERROR="'REMARKS' NOT VALID" Q
218 ;
219 Q VALID
220 ;
221 ;
222TESTVAL(SUB,VAL) ; Description: Used to determine if a field value is valid.
223 ;
224 ; Input:
225 ; SUB - as the field subscript
226 ; VAL - as the field value
227 ;
228 ; Output:
229 ; Function value: Returns 1 if the field value (VAL) is valid for
230 ; the subscript (SUB), returns 0 otherwise.
231 ;
232 N DISPLAY,FIELD,RESULT,VALID
233 ;
234 S VALID=1
235 ;
236 I (VAL'="") D
237 .S FIELD=$$FIELD(SUB)
238 .; if there is no external value then not valid
239 .S DISPLAY=$$EXTERNAL^DILFD(27.16,FIELD,"F",VAL)
240 .I (DISPLAY="") S VALID=0 Q
241 .I $$GET1^DID(27.16,FIELD,"","TYPE")'="POINTER" D
242 ..D CHK^DIE(27.16,FIELD,,VAL,.RESULT) I RESULT="^" S VALID=0 Q
243 ;
244 Q VALID
245 ;
246 ;
247FIELD(SUB) ; Description: Used to determine the field number for a given subscript in the EGT array.
248 ;
249 ; Input:
250 ; SUB - as the field subscript
251 ;
252 ; Output:
253 ; Function value: Returns the field number for the given subscript,
254 ; otherwise null is returned.
255 ;
256 ;
257 N FLD
258 S FLD=""
259 ;
260 D ; drops out of DO block once SUB is determined
261 .I SUB="EFFDATE" S FLD=.01 Q
262 .I SUB="PRIORITY" S FLD=.02 Q
263 .I SUB="SUBGRP" S FLD=.03 Q
264 .I SUB="TYPE" S FLD=.04 Q
265 .I SUB="FEDDATE" S FLD=.05 Q
266 .I SUB="ENTDATE" S FLD=.06 Q
267 .I SUB="SOURCE" S FLD=.07 Q
268 .I SUB="REMARKS" S FLD=25 Q
269 ;
270 Q FLD
271 ;
272INACT(EGTIEN,OLDIEN,DGEGT) ;inactivate EGT settings that are currently not in effect
273 ;
274 ; input: EGTIEN -Current EGT ien from 27.16
275 ; DGEGT (optional array) - Current EGT setting information
276 ; DGEGTF (optional) - do not inactivate future EGT
277 ;
278 Q:'$G(EGTIEN) 0
279 N EGTFDA,EGTDT,EGTREC,ERR
280 S:'$G(OLDIEN) OLDIEN=""
281 I '$D(DGEGT),'$$GET(EGTIEN,.DGEGT) Q 0
282 S:DGEGT("EFFDATE")>$$DT^XLFDT EGTF=1 ;future EGT setting
283 S EGTDT=""
284 F S EGTDT=$O(^DGEN(27.16,"B",EGTDT),-1) Q:'EGTDT D
285 .S EGTREC=""
286 .F S EGTREC=$O(^DGEN(27.16,"B",EGTDT,EGTREC),-1) Q:'EGTREC D
287 ..Q:EGTREC=EGTIEN ;new EGT setting
288 ..Q:$G(EGTF)&(EGTREC=OLDIEN)
289 ..I $P($G(^DGEN(27.16,EGTREC,0)),"^")>DT D Q
290 ...Q:$G(DGEGTF)
291 ...Q:$$DELETE(EGTREC)
292 ..S EGTFDA(27.16,EGTREC_",",.08)=1
293 D:$D(EGTFDA) UPDATE^DIE("","EGTFDA","","ERR")
294 Q 1
Note: See TracBrowser for help on using the repository browser.