source: cprs/branches/foia-cprs/CPRS-Chart/uProbs.pas@ 459

Last change on this file since 459 was 459, checked in by Kevin Toppenberg, 16 years ago

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