source: cprs/branches/HealthSevak-CPRS/CPRS-Chart/uProbs.pas@ 1723

Last change on this file since 1723 was 1693, checked in by healthsevak, 10 years ago

Committing the files for first time to this new branch
File size: 37.5 KB
Line 
1unit uProbs;
2
3interface
4
5uses
6 SysUtils, Windows, Messages, Controls, Classes, StdCtrls, ORfn,
7 ORCtrls, Dialogs, Forms, Grids, graphics, ORNet, uConst, Vawrgrid;
8
9const
10 fComStart=4;
11 v:char = #254;
12 PL_OP_VIEW:char = 'C';
13 PL_IP_VIEW:char = 'S';
14 PL_UF_VIEW:char = 'U';
15 PL_CLINIC:char ='C';
16 PL_WARD:char='W';
17 ACTIVE_LIST_CAP='Active Problems';
18 INACTIVE_LIST_CAP='Inactive Problems';
19 BOTH_LIST_CAP= 'Active and Inactive Problems';
20 REMOVED_LIST_CAP='Removed Problems';
21
22type
23
24{Key/value -internal/external pairs}
25 TKeyVal=class(TObject)
26 Id:string;
27 name:string; {may want to use instead of id sometime}
28 intern:string;
29 extern:string;
30 internOrig:string;
31 externOrig:string;
32 function GetDHCPField:string;
33 public
34 procedure DHCPtoKeyVal(DHCPFld:String);
35 property DHCPField:string read GetDHCPField;
36 end;
37
38 TComment=class(TObject)
39 IFN:string;
40 Facility:string;
41 Narrative:string;
42 Status:String;
43 DateAdd:string;
44 AuthorID:string;
45 AuthorName:String;
46 StatusFlag:string; {used for processing adds/deletes}
47 function GetExtDateAdd:string;
48 function GetAge:boolean;
49 constructor Create(dhcpcom:string);
50 destructor Destroy; override;
51 function TComtoDHCPCom:string;
52 property ExtDateAdd:string read GetExtDateAdd;
53 property IsNew:boolean read GetAge;
54 end;
55
56 {patient qualifiers}
57 TPLPt=class(TObject)
58 PtVAMC:string;
59 PtDead:string;
60 PtBid:string;
61 PtServiceConnected:boolean;
62 PtAgentOrange:boolean;
63 PtRadiation:boolean;
64 PtEnvironmental:boolean;
65 PtHNC:boolean;
66 PtMST:boolean;
67 PtSHAD:boolean;
68 constructor Create(Alist:TStringList);
69 function GetGMPDFN(dfn:string;name:String):string;
70 function Today:string;
71 end;
72
73 { User params}
74 TPLUserParams=class(TObject)
75 usPrimeUser:Boolean; {GMPLUSER true if clinical entry, false if clerical}
76 usDefaultView:String;
77 usCurrentView:String; {what view does user currently have? (OP,IP,Preferred,Unfilterred)}
78 usVerifyTranscribed:Boolean; {authority to verify transcribed problems}
79 usPromptforCopy:boolean;
80 usUseLexicon:boolean; {user will be using Lexicon}
81 usReverseChronDisplay:Boolean;
82 usViewAct:String; {viewing A)ctive, I)nactive, B)oth, R)emoved problems}
83 usViewProv:String; {prov (ptr #200) of displayed list or 0 for all}
84 usService:String; {user's service/section}
85 {I can't see where either of the ViewClin or ViewServ vals are setup in the
86 M application. They are documented in the PL V2.0 tech manual though}
87 usViewServ:string; {should be a list of ptr to file 49, format ptr/ptr/...}
88 usViewClin:string; {should be a list of ptr to file 44, format ptr/ptr/...}
89 usViewComments: string;
90 usDefaultContext: string;
91 usTesting:boolean; {used for test purposes only}
92 usClinList:TstringList;
93 usServList:TstringList;
94 constructor Create(alist:TstringList);
95 destructor Destroy; override;
96 end;
97
98 {filter lists}
99 TPLFilters = class(TObject)
100 ProviderList:TstringList;
101 ClinicList:TstringList;
102 ServiceList:TStringList;
103 constructor create;
104 destructor Destroy; override;
105 end;
106
107{problem record}
108 TProbRec = class(TObject)
109 private
110 fNewrec:Tstringlist;
111 fOrigRec:TStringList;
112 fPIFN:String;
113 fDiagnosis:Tkeyval; {.01}
114 fModDate:TKeyVal; {.03}
115 fNarrative:TKeyVal; {.05}
116 fEntDate:TKeyVal; { .08}
117 fStatus:TKeyVal; {.12}
118 fOnsetDate:TKeyVal; {.13}
119 fProblem:TKeyVal; {1.01}
120 fCondition:TKeyVal; {1.02}
121 fEntBy:TKeyVal; {1.03}
122 fRecBy:TKeyVal; {1.04}
123 fRespProv:TKeyVal; {1.05}
124 fService:TKeyVal; {1.06}
125 fResolveDate:TKeyVal; {1.07}
126 fClinic:TKeyVal; {1.08}
127 fRecordDate:TKeyVal; {1.09}
128 fServCon:TKeyVal; {1.1}
129 fAOExposure:TKeyVal; {1.11}
130 fRadExposure:TKeyVal; {1.12}
131 fGulfExposure:TKeyVal; {1.13}
132 fPriority:TKeyVal; {1.14}
133 fHNC:TKeyVal; {1.15}
134 fMST:TKeyVal; {1.16}
135 fCV:TKeyVal; {1.17} // this is not used value is always NULL
136 fSHAD:TKeyVal; {1.18}
137 fFieldList:TstringList; {list of fields by name and class (TKeyVal or TComment)}
138 fFilerObj:TstringList;
139 fCmtIsXHTML: boolean;
140 fCmtNoEditReason: string;
141 Procedure LoadField(Fldrec:TKeyVal;Id:String;name:string);
142 Procedure CreateFields;
143 procedure LoadComments;
144 procedure SetDate(datefld:TKeyVal;dt:TDateTime);
145 function GetModDate:TDateTime;
146 procedure SetModDate(value:TDateTime);
147 function GetEntDate:TDateTime;
148 procedure SetEntDate(value:TDateTime);
149 procedure SetOnsetDate(value:TDateTime);
150 function GetOnsetDate:TDateTime;
151 Function GetSCProblem:Boolean;
152 Procedure SetSCProblem(value:Boolean);
153 Function GetAOProblem:Boolean;
154 Procedure SetAOProblem(value:Boolean);
155 Function GetRADProblem:Boolean;
156 Procedure SetRADProblem(value:Boolean);
157 Function GetENVProblem:Boolean;
158 Procedure SetENVProblem(value:Boolean);
159 Function GetHNCProblem:Boolean;
160 Procedure SetHNCProblem(value:Boolean);
161 Function GetMSTProblem:Boolean;
162 Procedure SetMSTProblem(value:Boolean);
163 Function GetSHADProblem:Boolean;
164 Procedure SetSHADProblem(value:Boolean);
165 function GetStatus:String;
166 procedure SetStatus(value:String);
167 function GetPriority:String;
168 procedure SetPriority(value:String);
169 function GetRESDate:TDateTime;
170 procedure SetRESDate(value:TDateTime);
171 function GetRECDate:TDateTime;
172 procedure SetRECDate(value:TDateTime);
173 procedure SetNarrative(value:TKeyVal);
174 function GetTDateTime(dt:string):TDateTime;
175 function GetFilerObject:TstringList;
176 function GetAltFilerObject:TstringList;
177 function GetCommentCount:integer;
178 Procedure EraseComments(clist:TList);
179 function GetModDatstr:string;
180 procedure SetModDatStr(value:string);
181 function GetEntDatstr:string;
182 procedure SetEntDatStr(value:string);
183 function GetOnsetDatstr:string;
184 procedure SetOnsetDatStr(value:string);
185 function GetResDatstr:string;
186 procedure SetResDatStr(value:string);
187 function GetRecDatstr:string;
188 procedure SetRecDatStr(value:string);
189 procedure SetDateString(df:TKeyVal;value:string);
190 function GetCondition:string;
191 procedure SetCondition(value:String);
192 public
193 fComments:TList; {comments}
194 procedure AddNewComment(Txt:string);
195 function FieldChanged(fldName:string):Boolean;
196 constructor Create(AList:TstringList);
197 destructor Destroy;override;
198 property RawNewRec:TstringList read fNewRec;
199 property RawOrigRec:TStringList read fOrigRec;
200 property DateModified:TDateTime read GetModDate write SetModDate;
201 property DateModStr:string read GetModDatStr write SetModDatStr;
202 property DateEntered:TDateTime read GetEntDate write SetEntDate;
203 property DateEntStr:string read GetEntDatStr write SetEntDatStr;
204 property DateOnset:TDateTime read GetOnsetDate write SetOnsetDate;
205 property DateOnsetStr:string read GetOnsetDatStr write SetOnsetDatStr;
206 property SCProblem:Boolean read GetSCProblem write SetSCProblem;
207 property AOProblem:Boolean read GetAOProblem write SetAOProblem;
208 property RADProblem:Boolean read GetRadProblem write SetRADProblem;
209 property ENVProblem:Boolean read GetENVProblem write SetENVProblem;
210 property HNCProblem:Boolean read GetHNCProblem write SetHNCProblem;
211 property MSTProblem:Boolean read GetMSTProblem write SetMSTProblem;
212 property SHADProlem:Boolean read GetSHADProblem write SetSHADProblem;
213 property Status:String read GetStatus write SetStatus;
214 property Narrative:TKeyVal read fNarrative write SetNarrative;
215 property Diagnosis:TKeyVal read fDiagnosis write fDiagnosis;
216 property Problem:TKeyVal read fProblem write fProblem;
217 property RespProvider:TKeyVal read fRespProv write fRespProv;
218 property EnteredBy:TKeyVal read fEntBy write fEntBy;
219 property RecordedBy:TKeyVal read fRecBy write fRecBy;
220 property Service:TKeyVal read fService write fService;
221 property Clinic:TKeyVal read fClinic write fClinic;
222 property DateResolved:TDateTime read GetResDate write SetResdate;
223 property DateResStr:string read GetResDatStr write SetResDatStr;
224 property DateRecorded:TDateTime read GetRecDate write SetRecdate;
225 property DateRecStr:string read GetRecDatStr write SetRecDatStr;
226 property Priority:string read GetPriority write SetPriority;
227 property Comments:TList read fComments write fComments;
228 property Condition:string read GetCondition write SetCondition;
229 property CommentCount:integer read GetCommentCount;
230 property FilerObject:TstringList read GetFilerObject;
231 property AltFilerObject:TstringList read GetAltFilerObject;
232 property PIFN:string read fPIFN write fPIFN;
233 property CmtIsXHTML: boolean read fCmtIsXHTML;
234 property CmtNoEditReason: string read fCmtNoEditReason;
235 end;
236
237var
238 ProbRec :TProbRec;
239 PLPt :TPLPt;
240 PLUser :TPLUserParams;
241 pProviderID :int64; {this is provider reviewing record, not resp provider}
242 pProviderName :string; {ditto}
243 PLFilters :TPLFilters;
244 PLProblem :string; {this is problem selected from lexicon lookup form}
245
246procedure GetListforIP(Alist:TstringList; AGrid: TCaptionListBox);
247procedure GetListforOP(Alist:TstringList; AGrid: TCaptionListBox);
248procedure LoadFilterList(Alist:TstringList;DestList:TstringList);
249procedure ShowFilterStatus(s: string);
250procedure InitViewFilters(Alist:TstringList);
251procedure SetViewFilters(Alist:TStringList);
252Function DateStringOK(ds:string):string;
253Function StripSpace(str:string):string;
254function ByProvider:String;
255function ForChars(Num, FontWidth: Integer): Integer;
256procedure GetFontInfo(AHandle: THandle; var FontWidth, FontHeight: Integer);
257function ShortDateStrToDate(shortdate: string): string ;
258//function NewComment: string ;
259//function EditComment(OldValue: string): string ;
260function FixQuotes(Instring: string): string;
261
262implementation
263
264uses
265 rCore, uCore;//, fProbCmt;
266
267const
268 Months: array[1..12] of string[3] = ('JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC');
269
270{------------------- TKeyVal Class -----------------}
271function TKeyVal.GetDHCPField:string;
272begin
273 result := intern + u + extern;
274end;
275
276procedure TKeyVal.DHCPtoKeyVal(DHCPFld:String);
277begin
278 intern := Piece(DHCPFld,u,1);
279 extern := Piece(DHCPFLd,u,2);
280end;
281
282{------------------- TComment Class ----------------}
283constructor TComment.Create(dhcpcom:string);
284begin
285 {create and instantiate a Tcomment object}
286 IFN:=Piece(dhcpcom,u,1);
287 Facility:=Piece(dhcpcom,u,2);
288 Narrative:=Piece(dhcpcom,u,3);
289 Status:=Piece(dhcpcom,u,4);
290 DateAdd:=Piece(dhcpcom,u,5);
291 AuthorID:=Piece(dhcpcom,u,6);
292 AuthorName:=Piece(dhcpcom,u,7);
293 StatusFlag:='';
294end;
295
296destructor TComment.Destroy;
297begin
298 inherited destroy;
299end;
300
301function TComment.TComtoDHCPCom:string;
302begin
303 Narrative := FixQuotes(Narrative);
304 if uppercase(IFN)='NEW' then {new note}
305 result := Narrative
306 else {potential edit of existing note}
307 result := IFN + u + Facility + u + Narrative + u +
308 Status + u + DateAdd + u + AuthorID; {leave off author name}
309end;
310
311function TComment.GetExtDateAdd:String;
312begin
313 result := FormatFMDateTime('mmm dd yyyy',StrToFloat(DateAdd)) ;
314end;
315
316function TComment.Getage:boolean;
317begin
318 result := uppercase(IFN)='NEW';
319end;
320
321{-------------------------- TPLPt Class ----------------------}
322constructor TPLPt.Create(Alist:TStringList);
323var
324 i: integer;
325begin
326 for i := 0 to AList.Count - 1 do
327 case i of
328 0: PtVAMC := copy(Alist[i],1,999);
329 1: PtDead := AList[i];
330 2: PtServiceConnected := (AList[i] = '1');
331 3: PtAgentOrange := (AList[i] = '1');
332 4: PtRadiation := (AList[i] = '1');
333 5: PtEnvironmental := (AList[i] = '1');
334 6: PtBID := Alist[i];
335 7: PtHNC := (AList[i] = '1');
336 8: PtMST := (AList[i] = '1');
337 //9:CombatVet Not tracked in Problem list
338 10: PtSHAD := (AList[i] = '1');
339 end;
340end;
341
342function TPLPt.GetGMPDFN(dfn:string;name:string):string;
343begin
344 result := dfn + u + name + u + PtBID + u + PtDead
345end;
346
347function TPLPt.Today:string;
348{returns string in DHCP^mmm dd yyyy format}
349begin
350 result := Piece(FloatToStr(FMToday),'.',1) + u + FormatFMDateTime('mmm dd yyyy',FMToday) ;
351end;
352
353{-------------------- TUserParams -------------------------------}
354constructor TPLUserParams.create(alist:TstringList);
355var
356 p:string;
357 i:integer;
358begin
359 usPrimeUser := false;
360 usDefaultView := '';
361 usVerifyTranscribed := True; // SHOULD DEFAULT BE FALSE???
362 usPromptforCopy := false;
363 usUseLexicon := false;
364 usReverseChronDisplay := true;
365 usViewAct := 'A';
366 usViewProv := '0^All';
367 usService := '';
368 usViewcomments := '0';
369 usClinList := TstringList.create;
370 usServList := TstringList.create;
371 if alist.count=0 then exit; {BAIL OUT IF LIST EMPTY}
372 //usPrimeUser := False; {for testing}
373 usPrimeUser := (alist[0]='1');
374 usDefaultView := alist[1];
375 if usDefaultView = '' then
376 begin
377 if Patient.Inpatient then usDefaultView := PL_IP_VIEW
378 else usDefaultView := PL_OP_VIEW;
379 end;
380 usVerifyTranscribed := (alist[2]='1');
381 usPromptforCopy := (alist[3]='1');
382 //usUseLexicon := False; {for testing}
383 usUseLexicon := (alist[4]='1');
384 usReverseChronDisplay := (alist[5]='1');
385 usViewAct := alist[6];
386 usViewProv := alist[7];
387 usService := alist[8];
388 usViewServ := alist[9];
389 usViewClin := alist[10];
390 usTesting := (alist[11]<>'');
391 usViewComments := AList[12];
392 usCurrentView := usDefaultView;
393 usDefaultContext := ';;' + usViewAct + ';' + usViewComments + ';' + Piece(usViewProv, U, 1);
394 if usViewClin <> '' then
395 begin
396 i := 1;
397 repeat
398 begin
399 p := Piece(usViewClin,'/',i);
400 inc(i);
401 if p <> '' then usClinList.add(p);
402 end;
403 until p = '';
404 end;
405 if usViewServ <> '' then
406 begin
407 i := 1;
408 repeat
409 begin
410 p := Piece(usViewServ,'/',i);
411 inc(i);
412 if p <> '' then usServList.add(p);
413 end;
414 until p = '';
415 end;
416end;
417
418destructor TPLUserParams.Destroy;
419begin
420 usClinList.free;
421 usServList.free;
422 inherited destroy;
423end;
424
425{-------------------- TPLFilters -------------------}
426constructor TPLFilters.Create;
427begin
428 ProviderList := TstringList.create;
429 ClinicList := TstringList.create;
430 ServiceList := TStringList.create;
431end;
432
433destructor TPLFilters.destroy;
434begin
435 ProviderList.free;
436 ClinicList.Free;
437 ServiceList.Free;
438 inherited destroy;
439end;
440
441{------------------ TProbRec -----------------------}
442constructor TProbRec.create(AList:TstringList);
443var
444 i: integer;
445begin
446 fFieldList := TstringList.create;
447 fFilerObj := TStringList.Create;
448 fNewRec := TstringList.create;
449 for i := 0 to Pred(Alist.count) do
450 if copy(Alist[i],1,3) = 'NEW' then fNewRec.add(Alist[i]);
451 fOrigRec := TStringList.Create;
452 for i := 0 to pred(Alist.count) do
453 if copy(Alist[i],1,3) = 'ORG' then fOrigRec.add(Alist[i]);
454 CreateFields;
455 {names selected to agree with subscripts of argument array to callable
456 entrypoints in ^GMPUTL where possible.}
457 LoadField(fDiagnosis,'.01','DIAGNOSIS');
458 LoadField(fModDate,'.03','MODIFIED');
459 LoadField(fNarrative,'.05','NARRATIVE');
460 LoadField(fEntDate,'.08','ENTERED');
461 LoadField(fStatus,'.12','STATUS');
462 LoadField(fOnsetDate,'.13','ONSET');
463 LoadField(fProblem,'1.01','LEXICON');
464 LoadField(fCondition,'1.02','CONDITION');
465 LoadField(fEntBy,'1.03','ENTERER');
466 LoadField(fRecBy,'1.04','RECORDER');
467 LoadField(fRespProv,'1.05','PROVIDER');
468 LoadField(fService,'1.06','SERVICE');
469 LoadField(fResolveDate,'1.07','RESOLVED');
470 LoadField(fClinic,'1.08','LOCATION');
471 LoadField(fRecordDate,'1.09','RECORDED');
472 LoadField(fServCon,'1.1','SC');
473 LoadField(fAOExposure,'1.11','AO');
474 LoadField(fRadExposure,'1.12','IR');
475 LoadField(fGulfExposure,'1.13','EC');
476 LoadField(fPriority,'1.14','PRIORITY');
477 LoadField(fHNC,'1.15','HNC');
478 LoadField(fMST,'1.16','MST');
479 LoadField(fCV,'1.17','CV'); // not used at this time
480 LoadField(fSHAD,'1.18','SHD');
481 LoadComments;
482end;
483
484destructor TProbRec.destroy;
485begin
486 fOrigRec.free;
487 fNewrec.free;
488 fDiagnosis.free;
489 fModDate.free;
490 fNarrative.free;
491 fEntDate.free;
492 fStatus.free;
493 fOnsetDate.free;
494 fProblem.free;
495 fCondition.free;
496 fRespProv.free;
497 fEntBy.free;
498 fRecBy.Free;
499 fService.free;
500 fResolveDate.free;
501 fClinic.free;
502 fRecordDate.free;
503 fServCon.free;
504 fAOExposure.free;
505 fRadExposure.free;
506 fGulfExposure.free;
507 fPriority.free;
508 fHNC.free;
509 fMST.free;
510 fSHAD.Free;
511 fCV.Free;
512 fFieldList.free;
513 fFilerObj.free;
514 EraseComments(fComments);
515 fComments.free;
516 inherited Destroy;
517end;
518
519procedure TProbRec.EraseComments(clist:TList);
520var
521 i:integer;
522begin
523 if clist.count>0 then
524 begin
525 for i:=0 to pred(clist.count) do
526 TComment(clist[i]).free;
527 end;
528end;
529
530procedure TProbRec.CreateFields;
531begin
532 fDiagnosis:=TKeyVal.create;
533 fModDate:=TKeyVal.create;
534 fNarrative:=TKeyVal.create;
535 fEntDate:=TKeyVal.create;
536 fStatus:=TKeyVal.create;
537 fOnsetDate:=TKeyVal.create;
538 fProblem:=TKeyVal.create;
539 fCondition:=TKeyVal.create;
540 fEntBy:=TKeyVal.create;
541 fRecBy:=TKeyVal.create;
542 fRespProv:=TKeyVal.create;
543 fService:=TKeyVal.create;
544 fResolveDate:=TKeyVal.create;
545 fClinic:=TKeyVal.create;
546 fRecordDate:=TKeyVal.create;
547 fServCon:=TKeyVal.create;
548 fAOExposure:=TKeyVal.create;
549 fRadExposure:=TKeyVal.create;
550 fGulfExposure:=TKeyVal.create;
551 fPriority:=TKeyVal.create;
552 fHNC:=TKeyVal.create;
553 fMST:=TKeyVal.create;
554 fCV := TKeyVal.create;
555 fSHAD:=TKeyVal.Create;
556 fComments:=TList.create;
557end;
558
559procedure TProbRec.LoadField(Fldrec:TKeyVal;Id:String;name:string);
560var
561 i:integer;
562 fldval:string;
563
564 function GetOrigVal(id:string):string;
565 var
566 i:integer;
567 begin
568 i := 0;
569 Result := '^';
570 if fOrigRec.count = 0 then exit;
571 while (i < fOrigRec.Count) and (Piece(fOrigRec[i],v,2)<>id) do inc(i);
572 if i = fOrigRec.Count then exit;
573 if Piece(fOrigRec[i],v,2) = id then Result := Piece(fOrigRec[i],v,3)
574 end;
575
576begin
577 i := -1;
578 repeat
579 inc(i);
580 until (Piece(fNewRec[i],v,2) = id) or (i = Pred(fNewRec.count));
581 if Piece(fNewrec[i],v,2) = id then
582 fldVal := Piece(fNewrec[i],v,3)
583 else
584 fldVal := '^';
585 fldRec.id := id;
586 fldrec.name := name;
587 fldRec.intern := Piece(fldVal,'^',1);
588 fldRec.extern := Piece(fldval,'^',2);
589 {get the original values for later comparison}
590 fldVal := GetOrigVal(id);
591 fldRec.internOrig := Piece(fldVal,'^',1);
592 fldRec.internOrig := Piece(fldVal,'^',2);
593 {add this field to list}
594 fFieldList.addobject(id,fldrec);
595end;
596
597procedure TProbrec.LoadComments;
598var
599 i,j:integer;
600 cv, noedit:string;
601 co:TComment;
602 first:boolean;
603begin
604 j := 1; {first comment must be 1 or greater}
605 first := true;
606 for i := 0 to Pred(fNewRec.count) do
607 begin
608 if Piece(Piece(fNewRec[i],v,2),',',1) = '10' then
609 begin
610 if first then {the first line is just a counter}
611 begin
612 first := false;
613 // 'NEWþ10,0þ-1^These notes are now in XHTML format and must be modified via CPRS-R.'
614 noedit := Piece(fNewRec[i], v, 3);
615 if Piece(noedit, U, 1) = '-1' then
616 begin
617 fCmtIsXHTML := TRUE;
618 fCmtNoEditReason := Piece(noedit, U, 2);
619 end
620 else
621 begin
622 fCmtIsXHTML := FALSE;
623 fCmtNoEditReason := '';
624 end;
625 end
626 else
627 begin
628 cv := Piece(fNewRec[i],v,3);
629 co := TComment.Create(cv);
630 fComments.add(co); {put object in list}
631 fFieldList.addObject('10,' + inttostr(j),co);
632 inc(j);
633 end;
634 end;
635 end;
636end;
637
638function TProbRec.GetCommentCount:integer;
639begin
640 result := fComments.count;
641end;
642
643procedure TProbRec.AddNewComment(Txt:string);
644var
645 cor:TComment;
646begin
647 cor := TComment.create('NEW^^' + txt + '^A^' + FloatToStr(FMToday) + '^' + IntToStr(User.DUZ));
648 fComments.add(cor);
649 fFieldList.addObject('10,"NEW",' + inttostr(fComments.count),cor);
650end;
651
652function TProbrec.GetModDate:TDateTime;
653var
654 dt:string;
655begin
656 dt := fModDate.extern;
657 result := GetTDateTime(dt);
658end;
659
660procedure TProbrec.SetModDate(value:TDateTime);
661begin
662 SetDate(fModDate,value);
663end;
664
665function TProbRec.GetModDatstr:string;
666begin
667 result := fModdate.extern;
668end;
669
670procedure TProbRec.SetModDatStr(value:String);
671begin
672 SetDateString(fModDate,value);
673end;
674
675procedure TProbRec.SetDateString(df:TKeyVal;value:string);
676var
677 {c:char;
678 days:longint;}
679 fmresult: double ;
680begin
681 {try }
682 if (value = '') then
683 begin
684 df.Intern := '';
685 df.Extern := '';
686 end
687 else
688 begin
689 fmresult := StrToFMDateTime(value) ;
690 if fmresult = -1 then
691 begin
692 df.intern := '0';
693 df.extern := '';
694 end
695 else
696 begin
697 df.intern := Piece(FloatToStr(fmresult),'.',1);
698 df.extern := FormatFMDateTime('mmm dd yyyy',fmresult);
699 end ;
700 end;
701end;
702
703function TProbrec.GetEntDate:TDateTime;
704var
705 dt:string;
706begin
707 dt := fEntDate.extern;
708 result := GetTDateTime(dt);
709end;
710
711procedure TProbrec.SetEntDate(value:TDateTime);
712begin
713 SetDate(fEntDate,value);
714end;
715
716function TProbRec.GetEntDatstr:string;
717begin
718 result:=fEntdate.extern;
719end;
720
721procedure TProbRec.SetEntDatStr(value:String);
722begin
723 SetDateString(fEntDate,value);
724end;
725
726function TProbrec.GetOnsetDate:TDateTime;
727var
728 dt:string;
729begin
730 dt := fOnsetDate.extern;
731 result := GetTDateTime(dt);
732end;
733
734procedure TProbrec.SetOnsetDate(value:TDateTime);
735begin
736 SetDate(fOnsetDate,value);
737end;
738
739function TProbRec.GetOnsetDatstr:string;
740begin
741 result := fOnsetdate.extern;
742end;
743
744procedure TProbRec.SetOnsetDatStr(value:String);
745begin
746 SetDateString(fOnsetDate,value);
747end;
748
749procedure TProbrec.SetDate(datefld:TKeyVal;dt:TDateTime);
750begin
751 datefld.extern := DatetoStr(dt);
752 datefld.intern := FloatToStr(DateTimetoFMDateTime(dt));
753end;
754
755function TProbrec.GetSCProblem:Boolean;
756begin
757 result := (fServCon.Intern='1');
758end;
759
760function TProbRec.GetCondition:string;
761begin
762 result := fCondition.Intern;
763end;
764
765procedure TProbRec.SetCondition(value:string);
766begin
767 if (uppercase(value[1])='T') or (value='1') then
768 begin
769 fCondition.intern := 'T';
770 fCondition.extern := 'Transcribed';
771 end
772 else if (uppercase(value[1]) = 'P') or (value = '0') then
773 begin
774 fCondition.intern := 'P';
775 fCondition.extern := 'Permanent';
776 end
777 else if uppercase(value[1]) = 'H' then
778 begin
779 fCondition.intern := 'H';
780 fCondition.extern := 'Hidden';
781 end;
782end;
783
784procedure TProbRec.SetSCProblem(value:Boolean);
785begin
786 if value = true then
787 begin
788 fServCon.intern := '1';
789 fServCon.Extern := 'YES';
790 end
791 else
792 begin
793 fServCon.intern := '0';
794 fServCon.Extern := 'NO';
795 end;
796end;
797
798function TProbrec.GetAOProblem:Boolean;
799begin
800 result := (fAOExposure.Intern='1');
801end;
802
803procedure TProbRec.SetAOProblem(value:Boolean);
804begin
805 if value = true then
806 begin
807 fAOExposure.intern := '1';
808 fAOExposure.extern := 'Yes';
809 end
810 else
811 begin
812 fAOExposure.intern := '0';
813 fAOExposure.extern := 'No';
814 end;
815end;
816
817function TProbrec.GetRADProblem:Boolean;
818begin
819 result := (fRADExposure.Intern = '1');
820end;
821
822procedure TProbRec.SetRADProblem(value:Boolean);
823begin
824 if value = true then
825 begin
826 fRADExposure.intern := '1';
827 fRADExposure.extern := 'Yes';
828 end
829 else
830 begin
831 fRADExposure.intern := '0';
832 fRADExposure.extern := 'No';
833 end;
834 end;
835
836function TProbrec.GetENVProblem:Boolean;
837begin
838 result := (fGulfExposure.Intern = '1');
839end;
840
841procedure TProbRec.SetENVProblem(value:Boolean);
842begin
843 if value = true then
844 begin
845 fGulfExposure.intern := '1';
846 fGulfExposure.extern := 'Yes';
847 end
848 else
849 begin
850 fGulfExposure.intern := '0';
851 fGulfExposure.extern := 'No';
852 end;
853 end;
854
855function TProbrec.GetHNCProblem:Boolean;
856begin
857 result := (fHNC.Intern = '1');
858end;
859
860procedure TProbRec.SetHNCProblem(value:Boolean);
861begin
862 if value = true then
863 begin
864 fHNC.intern := '1';
865 fHNC.extern := 'Yes';
866 end
867 else
868 begin
869 fHNC.intern := '0';
870 fHNC.extern := 'No';
871 end;
872 end;
873
874function TProbrec.GetMSTProblem:Boolean;
875begin
876 result := (fMST.Intern = '1');
877end;
878
879procedure TProbRec.SetMSTProblem(value:Boolean);
880begin
881 if value = true then
882 begin
883 fMST.intern := '1';
884 fMST.extern := 'Yes';
885 end
886 else
887 begin
888 fMST.intern := '0';
889 fMST.extern := 'No';
890 end;
891 end;
892
893function TProbrec.GetSHADProblem:boolean;
894begin
895 result := (fSHAD.intern ='1');
896end;
897
898procedure TProbRec.SetSHADProblem(value:boolean);
899begin
900 if value = true then
901 begin
902 fSHAD.intern := '1';
903 fSHAD.extern := 'Yes';
904 end
905 else
906 begin
907 fSHAD.intern := '0';
908 fSHAD.extern := 'No';
909 end;
910end;
911
912function TProbRec.GetStatus:String;
913begin
914 result := Uppercase(fStatus.intern);
915end;
916
917procedure TProbRec.SetStatus(value:String);
918begin
919 if (UpperCase(Value) = 'ACTIVE') or (Uppercase(value) = 'A') then
920 begin
921 fStatus.intern := 'A';
922 fStatus.extern := 'ACTIVE';
923 end
924 else
925 begin
926 fStatus.intern := 'I';
927 fStatus.extern := 'INACTIVE';
928 end;
929end;
930
931function TProbRec.GetPriority:String;
932begin
933 result := Uppercase(fPriority.intern);
934end;
935
936procedure TProbRec.SetPriority(value:String);
937begin
938 if (UpperCase(Value) = 'ACUTE') or (Uppercase(value) = 'A') then
939 begin
940 fPriority.intern := 'A';
941 fPriority.extern := 'ACUTE';
942 end
943 else
944 begin
945 fPriority.intern := 'C';
946 fPriority.extern := 'CHRONIC';
947 end;
948end;
949
950function TProbrec.GetResDate:TDateTime;
951var
952 dt:string;
953begin
954 dt := fResolveDate.extern;
955 result := GetTDateTime(dt);
956end;
957
958procedure TProbrec.SetResDate(value:TDateTime);
959begin
960 SetDate(fResolveDate,value);
961end;
962
963function TProbRec.GetResDatstr:string;
964begin
965 result := fResolvedate.extern;
966end;
967
968procedure TProbRec.SetResDatStr(value:String);
969begin
970 SetDateString(fResolveDate,value);
971end;
972
973function TProbrec.GetRecDate:TDateTime;
974var
975 dt:string;
976begin
977 dt := fRecordDate.extern;
978 result := GetTDateTime(dt);
979end;
980
981procedure TProbrec.SetRecDate(value:TDateTime);
982begin
983 SetDate(fRecordDate,value);
984end;
985
986function TProbRec.GetRecDatstr:string;
987begin
988 result := fRecordDate.extern;
989end;
990
991procedure TProbRec.SetRecDatStr(value:String);
992begin
993 SetDateString(fRecordDate,value);
994end;
995
996procedure TProbRec.SetNarrative(value:TKeyVal);
997begin
998 if (value.intern = '') or (value.extern = '') then
999 begin
1000 InfoBox('Both internal and external values required', 'Error', MB_OK or MB_ICONERROR);
1001 exit;
1002 end;
1003 fNarrative.intern := value.intern;
1004 fNarrative.extern := value.extern;
1005end;
1006
1007function TProbRec.GetTDateTime(dt:string):TDateTime;
1008begin
1009 try
1010 if dt = '' then result := 0 else result := StrtoDate(dt);
1011 except on exception do
1012 result := 0;
1013 end;
1014end;
1015
1016{--------------------------------- Filer Objects -------------------------}
1017
1018function TProbRec.GetFilerObject:TstringList;
1019{return array for filing in dhcp}
1020var
1021 i:integer;
1022 fldID,fldVal: string;
1023begin
1024 fFilerObj.clear;
1025 for i := 0 to pred(fFieldList.count) do
1026 begin
1027 fldID := fFieldList[i];
1028 if pos(',',fldID)>0 then {is a comment field}
1029 fldVal := TComment(fFieldList.objects[i]).TComtoDHCPCom
1030 else {is a regular field}
1031 begin
1032 if fldID = '1.02' then {have to make exception for CONDITION field}
1033 fldVal := TKeyVal(fFieldList.objects[i]).intern
1034 else
1035 fldVal := FixQuotes(TKeyVal(fFieldList.objects[i]).DHCPField);
1036 end;
1037 fFilerObj.add('GMPFLD(' + fldID + ')="' + fldVal + '"');
1038 end;
1039 fFilerObj.add('GMPFLD(10,0)="' + inttostr(fComments.count) + '"');
1040 {now get original fields}
1041 for i := 0 to pred(fOrigRec.count) do
1042 begin
1043 fldVal := fOrigRec[i];
1044 fldID := Piece(fldVal,v,2);
1045 fldVal := FixQuotes(Piece(fldVal,v,3));
1046 fFilerObj.add('GMPORIG(' + fldID + ')="' + fldVal + '"');
1047 end;
1048 result := fFilerObj;
1049end;
1050
1051function TProbRec.GetAltFilerObject:TstringList;
1052{return array for filing in dhcp via UPDATE^GMPLUTL}
1053{NOTES:
1054 - leave narrative out, looks like inclusion causes new entry
1055 - Date recorded (1.09) is non-editable, causes error if present}
1056var
1057 i: integer;
1058 fldID,fldVal: string;
1059begin
1060 fFilerObj.Clear;
1061 for i := 0 to pred(fFieldList.count) do
1062 begin
1063 fldID := fFieldList[i];
1064 if pos(u + fldID + u, '^.01^.12^.13^1.01^1.05^1.07^1.08^1.1^1.11^1.12^1.13^1.15^1.16^1.18') > 0 then
1065 {is a field eligible for update}
1066 begin
1067 fldVal := TKeyVal(fFieldList.objects[i]).intern;
1068 fFilerObj.add('ORARRAY("' + TkeyVal(fFieldList.objects[i]).Name + '")="' + fldVal + '"');
1069 end;
1070 end;
1071 fFilerObj.add('ORARRAY("PROBLEM")="' + fPIFN + '"');
1072 result := fFilerObj;
1073end;
1074
1075function TProbRec.FieldChanged(fldName:string):boolean;
1076var
1077 i: integer;
1078begin
1079 i := -1;
1080 repeat
1081 inc(i);
1082 until (TKeyVal(fFieldList.objects[i]).name = fldName) or
1083 (i=Pred(fFieldList.count));
1084 if (TKeyVal(fFieldList.objects[i]).name = fldName) and
1085 (TKeyVal(fFieldList.objects[i]).intern = TKeyVal(fFieldList.objects[i]).internOrig) then
1086 Result := false
1087 else
1088 Result := true;
1089end;
1090
1091{----------------------------------- Check Date -------------------------------}
1092
1093function DateStringOK(ds: string): string;
1094var
1095 fmresult: double ;
1096begin
1097 ds := StripSpace(ds);
1098 result := ds;
1099 if ds = '' then exit;
1100 if Copy(ds,1,1) = ',' then ds := Copy(ds, 2, 99) ;
1101 fmresult := StrToFMDateTime(ds) ;
1102 if fmresult = -1 then
1103 result := 'ERROR'
1104 else
1105 result := FormatFMDateTime('mmm dd yyyy',fmresult) ;
1106end;
1107
1108function StripSpace(str: string): string;
1109var
1110 i,j: integer;
1111begin
1112 i := 1;
1113 j := length(str);
1114 while str[i] = #32 do inc(i);
1115 while str[j] = #32 do dec(j);
1116 result := copy(str, i, j-i+1);
1117end;
1118
1119{-------------------- procedures used in View Filters ----------------------}
1120
1121procedure GetListforIP(Alist:TstringList; AGrid: TCaptionListBox);
1122var
1123 i:integer;
1124 sv:string;
1125 anon:boolean;
1126begin
1127 anon:=false;
1128 with AGrid do
1129 for i := 0 to pred(items.count) do
1130 begin
1131 //pt := cells[12,i];
1132 {location type is ward, or no clinic and service is non nil}
1133 {if (pt = PL_WARD) or ((cells[10,i] = '') and (cells[11,i] <> '')) then
1134 begin }
1135 sv := Piece( items[i], U, 12);
1136 if sv <> '' then
1137 begin
1138 if Alist.indexof(sv) < 0 then Alist.add(sv);
1139 end
1140 else if (sv = '') and (not anon) then
1141 begin
1142 Alist.add('-1^<None recorded>');
1143 anon := true;
1144 end;
1145 //end;
1146 end;
1147end;
1148
1149Procedure GetListforOP(Alist:TstringList; AGrid: TCaptionListBox);
1150var {get list of extant clinics from patient's problem list}
1151 i: integer;
1152 clin: string;
1153 anon: boolean;
1154begin
1155 anon := false;
1156 with AGrid do
1157 for i := 0 to pred(items.count) do
1158 {begin
1159 pt := cells[12,i];
1160 if pt <> PL_WARD then}
1161 begin
1162 clin := Piece( items[i], U, 11);
1163 if ((clin = '') or (clin = '0')) and (not anon) then
1164 begin
1165 AList.add('-1^<None recorded>'); {add a holder for "no clinic"}
1166 anon := true;
1167 end
1168 else if (clin<>'') and (Alist.indexof(clin)<0) then
1169 Alist.add(clin);
1170 end;
1171 //end;
1172end;
1173
1174procedure LoadFilterList(Alist: TstringList; DestList: TstringList);
1175var
1176 i:integer;
1177begin
1178 for i := 0 to pred(Alist.count) do DestList.add(Piece(Alist[i],u,1));
1179end;
1180
1181procedure ShowFilterStatus(s: string);
1182var
1183 lin:string;
1184begin
1185 if s = PL_OP_VIEW then lin := 'View clinics'
1186 else if s = PL_IP_VIEW then lin := 'View services'
1187 else lin := 'View all problems';
1188 Application.ProcessMessages;
1189end;
1190
1191function ByProvider: string;
1192begin
1193 result := '';
1194 if PLFilters.ProviderList.count > 0 then
1195 if PLFilters.ProviderList[0] <> '0' then result := 'by Provider';
1196end;
1197
1198procedure SetViewFilters(Alist:TStringList);
1199begin
1200 if PLFilters.ProviderList.count = 0 then
1201 PLFilters.ProviderList.add('0'); {default to all provides if none selected}
1202 if PLUser.usCurrentView = PL_OP_VIEW then
1203 begin
1204 if PLFilters.ClinicList.count = 0 then
1205 begin
1206 //GetListforOP(Alist);
1207 LoadFilterList(Alist,PLFilters.ClinicList);
1208 end;
1209 //PostMessage(frmProblems.Handle, UM_PLFILTER,0,0);
1210 end
1211 else if PLUser.usCurrentView = PL_IP_VIEW then
1212 begin
1213 if PLFilters.ServiceList.count=0 then
1214 begin
1215 //GetListforIP(Alist);
1216 LoadFilterList(Alist,PLFilters.ServiceList);
1217 end;
1218 //PostMessage(frmProblems.Handle, UM_PLFILTER,0,0);
1219 end
1220 else {if no default view specified, assumed to be unfiltered}
1221 PlUser.usCurrentView := PL_UF_VIEW;
1222 ShowFilterStatus(PlUser.usCurrentView);
1223end;
1224
1225procedure InitViewFilters(Alist: TstringList);
1226var
1227 i:integer;
1228begin
1229 if PLUser.usCurrentView = '' then PLUser.usCurrentView := PL_UF_VIEW;
1230
1231 if (PLUser.usViewProv = '') or (Piece(PLUser.usViewProv, U, 1) = '0') then
1232 begin
1233 PLFilters.ProviderList.clear;
1234 PLFilters.Providerlist.add('0');
1235 end
1236 else {conserve user preferred provider}
1237 PLFilters.ProviderList.Add(Piece(PLUser.usViewProv, U, 1));
1238
1239 if PLUser.usCurrentView = PL_UF_VIEW then
1240 begin {no filter on patient type, so do routine filter on provider and bail}
1241 SetViewFilters(Alist);
1242 //exit;
1243 end;
1244
1245 if (PLUser.usCurrentView = PL_OP_VIEW) and (PLUser.usViewClin = '') then
1246 begin {no user preferred list of clinics, so get standard list and bail}
1247 SetViewFilters(Alist);
1248 //exit;
1249 end;
1250
1251 if (PLUser.usCurrentView = PL_IP_VIEW) and (PLUser.usViewServ = '') then
1252 begin {no user preferred list of services, so get standard list and bail}
1253 SetViewFilters(Alist);
1254 //exit;
1255 end;
1256
1257 if (PLUser.usCurrentView = PL_OP_VIEW) and (PLUser.usClinList.Count > 0) then
1258 begin {conserve user preferred clinic list}
1259 for i := 0 to pred(PLUser.usClinList.Count) do
1260 PLFilters.ClinicList.add(PLUser.usClinList[i]);
1261 end;
1262
1263 if PLUser.usCurrentView = PL_IP_VIEW then
1264 begin {conserve user preferred service list}
1265 for i := 0 to pred(PLUser.usServList.Count) do
1266 PLFilters.ServiceList.add(PLUser.usServList[i]);
1267 end;
1268
1269// ShowFilterStatus(PlUser.usCurrentView);
1270// PostMessage(frmProblems.Handle, UM_PLFILTER,0,0);
1271end;
1272
1273function ForChars(Num, FontWidth: Integer): Integer;
1274begin
1275 Result := Num * FontWidth;
1276end;
1277
1278procedure GetFontInfo(AHandle: THandle; var FontWidth, FontHeight: Integer);
1279{ pass in a FONT HANDLE & return character width & height }
1280var
1281 DC: HDC;
1282 SaveFont: HFont;
1283 FontMetrics: TTextMetric;
1284 size: TSize ;
1285begin
1286 DC := GetDC(0);
1287 SaveFont := SelectObject(DC, AHandle);
1288 GetTextExtentPoint32(DC, UpperCaseLetters + LowerCaseLetters, 52, size);
1289 FontWidth := size.cx div 52;
1290 GetTextMetrics(DC, FontMetrics);
1291 FontHeight := FontMetrics.tmHeight;
1292 SelectObject(DC, SaveFont);
1293 ReleaseDC(0, DC);
1294end;
1295
1296function ShortDateStrToDate(shortdate: string): string ;
1297{Converts date in format 'mmm dd,yy' or 'mmm dd,yyyy' to standard 'mm/dd/yy'}
1298var
1299 month,day,year: string ;
1300 i: integer ;
1301begin
1302 result := 'ERROR' ;
1303 if ((Pos(' ',shortdate) <> 4) or (Pos(',',shortdate) <> 7)) then exit ; {no spaces or comma}
1304 for i := 1 to 12 do
1305 if Months[i] = UpperCase(Copy(shortdate,1,3)) then month := IntToStr(i);
1306 if month = '' then exit ; {invalid month name}
1307 day := IntToStr(StrToInt(Copy(shortdate,5,2))) ;
1308 year := IntToStr(StrToInt(Copy(shortdate,8,99))) ;
1309 result := month+'/'+day+'/'+year ;
1310end ;
1311
1312(*function NewComment: string ;
1313var
1314 frmProbCmt: TfrmProbCmt ;
1315begin
1316 frmProbCmt := TfrmProbCmt.Create(Application) ;
1317 try
1318 frmProbCmt.Execute;
1319 result := frmProbCmt.CmtResult ;
1320 finally
1321 frmProbCmt.Free ;
1322 end ;
1323end ;
1324
1325function EditComment(OldValue: string): string ;
1326var
1327 frmProbCmt: TfrmProbCmt ;
1328begin
1329 frmProbCmt := TfrmProbCmt.Create(Application) ;
1330 try
1331 frmProbCmt.edComment.Text := Piece(OldValue, U, 2);
1332 frmProbCmt.Execute;
1333 result := frmProbCmt.CmtResult ;
1334 finally
1335 frmProbCmt.Free ;
1336 end ;
1337end ;*)
1338
1339function FixQuotes(InString: string): string;
1340var
1341 i: integer;
1342 OutString: string;
1343begin
1344 OutString := '';
1345 for i := 1 to Length(InString) do
1346 if CharAt(InString, i) = '"' then
1347 OutString := OutString + '""'
1348 else
1349 OutString := OutString + CharAt(InString, i);
1350 Result := OutString;
1351end;
1352
1353end.
Note: See TracBrowser for help on using the repository browser.