source: cprs/trunk/CPRS-Chart/uProbs.pas@ 1556

Last change on this file since 1556 was 830, checked in by Kevin Toppenberg, 14 years ago

Upgrading to version 27
File size: 37.4 KB
RevLine 
[456]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;
[830]67 PtSHAD:boolean;
[456]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;
[830]104 destructor Destroy; override;
[456]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}
[830]116 fEntDate:TKeyVal; { .08}
[456]117 fStatus:TKeyVal; {.12}
118 fOnsetDate:TKeyVal; {.13}
119 fProblem:TKeyVal; {1.01}
120 fCondition:TKeyVal; {1.02}
[830]121 fEntBy:TKeyVal; {1.03}
122 fRecBy:TKeyVal; {1.04}
[456]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}
[830]135 fCV:TKeyVal; {1.17} // this is not used value is always NULL
136 fSHAD:TKeyVal; {1.18}
[456]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);
[830]163 Function GetSHADProblem:Boolean;
164 Procedure SetSHADProblem(value:Boolean);
[456]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;
[830]212 property SHADProlem:Boolean read GetSHADProblem write SetSHADProblem;
[456]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');
[830]337 //9:CombatVet Not tracked in Problem list
338 10: PtSHAD := (AList[i] = '1');
[456]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');
[830]479 LoadField(fMST,'1.17','CV'); // not used at this time
480 LoadField(fSHAD,'1.18','SHD');
[456]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 fFieldList.free;
511 fFilerObj.free;
512 EraseComments(fComments);
513 fComments.free;
514 inherited Destroy;
515end;
516
517procedure TProbRec.EraseComments(clist:TList);
518var
519 i:integer;
520begin
521 if clist.count>0 then
522 begin
523 for i:=0 to pred(clist.count) do
524 TComment(clist[i]).free;
525 end;
526end;
527
528procedure TProbRec.CreateFields;
529begin
530 fDiagnosis:=TKeyVal.create;
531 fModDate:=TKeyVal.create;
532 fNarrative:=TKeyVal.create;
533 fEntDate:=TKeyVal.create;
534 fStatus:=TKeyVal.create;
535 fOnsetDate:=TKeyVal.create;
536 fProblem:=TKeyVal.create;
537 fCondition:=TKeyVal.create;
538 fEntBy:=TKeyVal.create;
539 fRecBy:=TKeyVal.create;
540 fRespProv:=TKeyVal.create;
541 fService:=TKeyVal.create;
542 fResolveDate:=TKeyVal.create;
543 fClinic:=TKeyVal.create;
544 fRecordDate:=TKeyVal.create;
545 fServCon:=TKeyVal.create;
546 fAOExposure:=TKeyVal.create;
547 fRadExposure:=TKeyVal.create;
548 fGulfExposure:=TKeyVal.create;
549 fPriority:=TKeyVal.create;
550 fHNC:=TKeyVal.create;
551 fMST:=TKeyVal.create;
[830]552 fCV := TKeyVal.create;
553 fSHAD:=TKeyVal.Create;
[456]554 fComments:=TList.create;
555end;
556
557procedure TProbRec.LoadField(Fldrec:TKeyVal;Id:String;name:string);
558var
559 i:integer;
560 fldval:string;
561
562 function GetOrigVal(id:string):string;
563 var
564 i:integer;
565 begin
566 i := 0;
567 Result := '^';
568 if fOrigRec.count = 0 then exit;
569 while (i < fOrigRec.Count) and (Piece(fOrigRec[i],v,2)<>id) do inc(i);
570 if i = fOrigRec.Count then exit;
571 if Piece(fOrigRec[i],v,2) = id then Result := Piece(fOrigRec[i],v,3)
572 end;
573
574begin
575 i := -1;
576 repeat
577 inc(i);
578 until (Piece(fNewRec[i],v,2) = id) or (i = Pred(fNewRec.count));
579 if Piece(fNewrec[i],v,2) = id then
580 fldVal := Piece(fNewrec[i],v,3)
581 else
582 fldVal := '^';
583 fldRec.id := id;
584 fldrec.name := name;
585 fldRec.intern := Piece(fldVal,'^',1);
586 fldRec.extern := Piece(fldval,'^',2);
587 {get the original values for later comparison}
588 fldVal := GetOrigVal(id);
589 fldRec.internOrig := Piece(fldVal,'^',1);
590 fldRec.internOrig := Piece(fldVal,'^',2);
591 {add this field to list}
592 fFieldList.addobject(id,fldrec);
593end;
594
595procedure TProbrec.LoadComments;
596var
597 i,j:integer;
598 cv, noedit:string;
599 co:TComment;
600 first:boolean;
601begin
602 j := 1; {first comment must be 1 or greater}
603 first := true;
604 for i := 0 to Pred(fNewRec.count) do
605 begin
606 if Piece(Piece(fNewRec[i],v,2),',',1) = '10' then
607 begin
608 if first then {the first line is just a counter}
609 begin
610 first := false;
611 // 'NEWþ10,0þ-1^These notes are now in XHTML format and must be modified via CPRS-R.'
612 noedit := Piece(fNewRec[i], v, 3);
613 if Piece(noedit, U, 1) = '-1' then
614 begin
615 fCmtIsXHTML := TRUE;
616 fCmtNoEditReason := Piece(noedit, U, 2);
617 end
618 else
619 begin
620 fCmtIsXHTML := FALSE;
621 fCmtNoEditReason := '';
622 end;
623 end
624 else
625 begin
626 cv := Piece(fNewRec[i],v,3);
627 co := TComment.Create(cv);
628 fComments.add(co); {put object in list}
629 fFieldList.addObject('10,' + inttostr(j),co);
630 inc(j);
631 end;
632 end;
633 end;
634end;
635
636function TProbRec.GetCommentCount:integer;
637begin
638 result := fComments.count;
639end;
640
641procedure TProbRec.AddNewComment(Txt:string);
642var
643 cor:TComment;
644begin
645 cor := TComment.create('NEW^^' + txt + '^A^' + FloatToStr(FMToday) + '^' + IntToStr(User.DUZ));
646 fComments.add(cor);
647 fFieldList.addObject('10,"NEW",' + inttostr(fComments.count),cor);
648end;
649
650function TProbrec.GetModDate:TDateTime;
651var
652 dt:string;
653begin
654 dt := fModDate.extern;
655 result := GetTDateTime(dt);
656end;
657
658procedure TProbrec.SetModDate(value:TDateTime);
659begin
660 SetDate(fModDate,value);
661end;
662
663function TProbRec.GetModDatstr:string;
664begin
665 result := fModdate.extern;
666end;
667
668procedure TProbRec.SetModDatStr(value:String);
669begin
670 SetDateString(fModDate,value);
671end;
672
673procedure TProbRec.SetDateString(df:TKeyVal;value:string);
674var
675 {c:char;
676 days:longint;}
677 fmresult: double ;
678begin
679 {try }
680 if (value = '') then
681 begin
682 df.Intern := '';
683 df.Extern := '';
684 end
685 else
686 begin
687 fmresult := StrToFMDateTime(value) ;
688 if fmresult = -1 then
689 begin
690 df.intern := '0';
691 df.extern := '';
692 end
693 else
694 begin
695 df.intern := Piece(FloatToStr(fmresult),'.',1);
696 df.extern := FormatFMDateTime('mmm dd yyyy',fmresult);
697 end ;
698 end;
699end;
700
701function TProbrec.GetEntDate:TDateTime;
702var
703 dt:string;
704begin
705 dt := fEntDate.extern;
706 result := GetTDateTime(dt);
707end;
708
709procedure TProbrec.SetEntDate(value:TDateTime);
710begin
711 SetDate(fEntDate,value);
712end;
713
714function TProbRec.GetEntDatstr:string;
715begin
716 result:=fEntdate.extern;
717end;
718
719procedure TProbRec.SetEntDatStr(value:String);
720begin
721 SetDateString(fEntDate,value);
722end;
723
724function TProbrec.GetOnsetDate:TDateTime;
725var
726 dt:string;
727begin
728 dt := fOnsetDate.extern;
729 result := GetTDateTime(dt);
730end;
731
732procedure TProbrec.SetOnsetDate(value:TDateTime);
733begin
734 SetDate(fOnsetDate,value);
735end;
736
737function TProbRec.GetOnsetDatstr:string;
738begin
739 result := fOnsetdate.extern;
740end;
741
742procedure TProbRec.SetOnsetDatStr(value:String);
743begin
744 SetDateString(fOnsetDate,value);
745end;
746
747procedure TProbrec.SetDate(datefld:TKeyVal;dt:TDateTime);
748begin
749 datefld.extern := DatetoStr(dt);
750 datefld.intern := FloatToStr(DateTimetoFMDateTime(dt));
751end;
752
753function TProbrec.GetSCProblem:Boolean;
754begin
755 result := (fServCon.Intern='1');
756end;
757
758function TProbRec.GetCondition:string;
759begin
760 result := fCondition.Intern;
761end;
762
763procedure TProbRec.SetCondition(value:string);
764begin
765 if (uppercase(value[1])='T') or (value='1') then
766 begin
767 fCondition.intern := 'T';
768 fCondition.extern := 'Transcribed';
769 end
770 else if (uppercase(value[1]) = 'P') or (value = '0') then
771 begin
772 fCondition.intern := 'P';
773 fCondition.extern := 'Permanent';
774 end
775 else if uppercase(value[1]) = 'H' then
776 begin
777 fCondition.intern := 'H';
778 fCondition.extern := 'Hidden';
779 end;
780end;
781
782procedure TProbRec.SetSCProblem(value:Boolean);
783begin
784 if value = true then
785 begin
786 fServCon.intern := '1';
787 fServCon.Extern := 'YES';
788 end
789 else
790 begin
791 fServCon.intern := '0';
792 fServCon.Extern := 'NO';
793 end;
794end;
795
796function TProbrec.GetAOProblem:Boolean;
797begin
798 result := (fAOExposure.Intern='1');
799end;
800
801procedure TProbRec.SetAOProblem(value:Boolean);
802begin
803 if value = true then
804 begin
805 fAOExposure.intern := '1';
806 fAOExposure.extern := 'Yes';
807 end
808 else
809 begin
810 fAOExposure.intern := '0';
811 fAOExposure.extern := 'No';
812 end;
813end;
814
815function TProbrec.GetRADProblem:Boolean;
816begin
817 result := (fRADExposure.Intern = '1');
818end;
819
820procedure TProbRec.SetRADProblem(value:Boolean);
821begin
822 if value = true then
823 begin
824 fRADExposure.intern := '1';
825 fRADExposure.extern := 'Yes';
826 end
827 else
828 begin
829 fRADExposure.intern := '0';
830 fRADExposure.extern := 'No';
831 end;
832 end;
833
834function TProbrec.GetENVProblem:Boolean;
835begin
836 result := (fGulfExposure.Intern = '1');
837end;
838
839procedure TProbRec.SetENVProblem(value:Boolean);
840begin
841 if value = true then
842 begin
843 fGulfExposure.intern := '1';
844 fGulfExposure.extern := 'Yes';
845 end
846 else
847 begin
848 fGulfExposure.intern := '0';
849 fGulfExposure.extern := 'No';
850 end;
851 end;
852
853function TProbrec.GetHNCProblem:Boolean;
854begin
855 result := (fHNC.Intern = '1');
856end;
857
858procedure TProbRec.SetHNCProblem(value:Boolean);
859begin
860 if value = true then
861 begin
862 fHNC.intern := '1';
863 fHNC.extern := 'Yes';
864 end
865 else
866 begin
867 fHNC.intern := '0';
868 fHNC.extern := 'No';
869 end;
870 end;
871
872function TProbrec.GetMSTProblem:Boolean;
873begin
874 result := (fMST.Intern = '1');
875end;
876
877procedure TProbRec.SetMSTProblem(value:Boolean);
878begin
879 if value = true then
880 begin
881 fMST.intern := '1';
882 fMST.extern := 'Yes';
883 end
884 else
885 begin
886 fMST.intern := '0';
887 fMST.extern := 'No';
888 end;
889 end;
890
[830]891function TProbrec.GetSHADProblem:boolean;
892begin
893 result := (fSHAD.intern ='1');
894end;
895
896procedure TProbRec.SetSHADProblem(value:boolean);
897begin
898 if value = true then
899 begin
900 fSHAD.intern := '1';
901 fSHAD.extern := 'Yes';
902 end
903 else
904 begin
905 fSHAD.intern := '0';
906 fSHAD.extern := 'No';
907 end;
908end;
909
[456]910function TProbRec.GetStatus:String;
911begin
912 result := Uppercase(fStatus.intern);
913end;
914
915procedure TProbRec.SetStatus(value:String);
916begin
917 if (UpperCase(Value) = 'ACTIVE') or (Uppercase(value) = 'A') then
918 begin
919 fStatus.intern := 'A';
920 fStatus.extern := 'ACTIVE';
921 end
922 else
923 begin
924 fStatus.intern := 'I';
925 fStatus.extern := 'INACTIVE';
926 end;
927end;
928
929function TProbRec.GetPriority:String;
930begin
931 result := Uppercase(fPriority.intern);
932end;
933
934procedure TProbRec.SetPriority(value:String);
935begin
936 if (UpperCase(Value) = 'ACUTE') or (Uppercase(value) = 'A') then
937 begin
938 fPriority.intern := 'A';
939 fPriority.extern := 'ACUTE';
940 end
941 else
942 begin
943 fPriority.intern := 'C';
944 fPriority.extern := 'CHRONIC';
945 end;
946end;
947
948function TProbrec.GetResDate:TDateTime;
949var
950 dt:string;
951begin
952 dt := fResolveDate.extern;
953 result := GetTDateTime(dt);
954end;
955
956procedure TProbrec.SetResDate(value:TDateTime);
957begin
958 SetDate(fResolveDate,value);
959end;
960
961function TProbRec.GetResDatstr:string;
962begin
963 result := fResolvedate.extern;
964end;
965
966procedure TProbRec.SetResDatStr(value:String);
967begin
968 SetDateString(fResolveDate,value);
969end;
970
971function TProbrec.GetRecDate:TDateTime;
972var
973 dt:string;
974begin
975 dt := fRecordDate.extern;
976 result := GetTDateTime(dt);
977end;
978
979procedure TProbrec.SetRecDate(value:TDateTime);
980begin
981 SetDate(fRecordDate,value);
982end;
983
984function TProbRec.GetRecDatstr:string;
985begin
986 result := fRecordDate.extern;
987end;
988
989procedure TProbRec.SetRecDatStr(value:String);
990begin
991 SetDateString(fRecordDate,value);
992end;
993
994procedure TProbRec.SetNarrative(value:TKeyVal);
995begin
996 if (value.intern = '') or (value.extern = '') then
997 begin
998 InfoBox('Both internal and external values required', 'Error', MB_OK or MB_ICONERROR);
999 exit;
1000 end;
1001 fNarrative.intern := value.intern;
1002 fNarrative.extern := value.extern;
1003end;
1004
1005function TProbRec.GetTDateTime(dt:string):TDateTime;
1006begin
1007 try
1008 if dt = '' then result := 0 else result := StrtoDate(dt);
1009 except on exception do
1010 result := 0;
1011 end;
1012end;
1013
1014{--------------------------------- Filer Objects -------------------------}
1015
1016function TProbRec.GetFilerObject:TstringList;
1017{return array for filing in dhcp}
1018var
1019 i:integer;
1020 fldID,fldVal: string;
1021begin
1022 fFilerObj.clear;
1023 for i := 0 to pred(fFieldList.count) do
1024 begin
1025 fldID := fFieldList[i];
1026 if pos(',',fldID)>0 then {is a comment field}
1027 fldVal := TComment(fFieldList.objects[i]).TComtoDHCPCom
1028 else {is a regular field}
1029 begin
1030 if fldID = '1.02' then {have to make exception for CONDITION field}
1031 fldVal := TKeyVal(fFieldList.objects[i]).intern
1032 else
1033 fldVal := FixQuotes(TKeyVal(fFieldList.objects[i]).DHCPField);
1034 end;
1035 fFilerObj.add('GMPFLD(' + fldID + ')="' + fldVal + '"');
1036 end;
1037 fFilerObj.add('GMPFLD(10,0)="' + inttostr(fComments.count) + '"');
1038 {now get original fields}
1039 for i := 0 to pred(fOrigRec.count) do
1040 begin
1041 fldVal := fOrigRec[i];
1042 fldID := Piece(fldVal,v,2);
1043 fldVal := FixQuotes(Piece(fldVal,v,3));
1044 fFilerObj.add('GMPORIG(' + fldID + ')="' + fldVal + '"');
1045 end;
1046 result := fFilerObj;
1047end;
1048
1049function TProbRec.GetAltFilerObject:TstringList;
1050{return array for filing in dhcp via UPDATE^GMPLUTL}
1051{NOTES:
1052 - leave narrative out, looks like inclusion causes new entry
1053 - Date recorded (1.09) is non-editable, causes error if present}
1054var
1055 i: integer;
1056 fldID,fldVal: string;
1057begin
1058 fFilerObj.Clear;
1059 for i := 0 to pred(fFieldList.count) do
1060 begin
1061 fldID := fFieldList[i];
[830]1062 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
[456]1063 {is a field eligible for update}
1064 begin
1065 fldVal := TKeyVal(fFieldList.objects[i]).intern;
1066 fFilerObj.add('ORARRAY("' + TkeyVal(fFieldList.objects[i]).Name + '")="' + fldVal + '"');
1067 end;
1068 end;
1069 fFilerObj.add('ORARRAY("PROBLEM")="' + fPIFN + '"');
1070 result := fFilerObj;
1071end;
1072
1073function TProbRec.FieldChanged(fldName:string):boolean;
1074var
1075 i: integer;
1076begin
1077 i := -1;
1078 repeat
1079 inc(i);
1080 until (TKeyVal(fFieldList.objects[i]).name = fldName) or
1081 (i=Pred(fFieldList.count));
1082 if (TKeyVal(fFieldList.objects[i]).name = fldName) and
1083 (TKeyVal(fFieldList.objects[i]).intern = TKeyVal(fFieldList.objects[i]).internOrig) then
1084 Result := false
1085 else
1086 Result := true;
1087end;
1088
1089{----------------------------------- Check Date -------------------------------}
1090
1091function DateStringOK(ds: string): string;
1092var
1093 fmresult: double ;
1094begin
1095 ds := StripSpace(ds);
1096 result := ds;
1097 if ds = '' then exit;
1098 if Copy(ds,1,1) = ',' then ds := Copy(ds, 2, 99) ;
1099 fmresult := StrToFMDateTime(ds) ;
1100 if fmresult = -1 then
1101 result := 'ERROR'
1102 else
1103 result := FormatFMDateTime('mmm dd yyyy',fmresult) ;
1104end;
1105
1106function StripSpace(str: string): string;
1107var
1108 i,j: integer;
1109begin
1110 i := 1;
1111 j := length(str);
1112 while str[i] = #32 do inc(i);
1113 while str[j] = #32 do dec(j);
1114 result := copy(str, i, j-i+1);
1115end;
1116
1117{-------------------- procedures used in View Filters ----------------------}
1118
1119procedure GetListforIP(Alist:TstringList; AGrid: TCaptionListBox);
1120var
1121 i:integer;
1122 sv:string;
1123 anon:boolean;
1124begin
1125 anon:=false;
1126 with AGrid do
1127 for i := 0 to pred(items.count) do
1128 begin
1129 //pt := cells[12,i];
1130 {location type is ward, or no clinic and service is non nil}
1131 {if (pt = PL_WARD) or ((cells[10,i] = '') and (cells[11,i] <> '')) then
1132 begin }
1133 sv := Piece( items[i], U, 12);
1134 if sv <> '' then
1135 begin
1136 if Alist.indexof(sv) < 0 then Alist.add(sv);
1137 end
1138 else if (sv = '') and (not anon) then
1139 begin
1140 Alist.add('-1^<None recorded>');
1141 anon := true;
1142 end;
1143 //end;
1144 end;
1145end;
1146
1147Procedure GetListforOP(Alist:TstringList; AGrid: TCaptionListBox);
1148var {get list of extant clinics from patient's problem list}
1149 i: integer;
1150 clin: string;
1151 anon: boolean;
1152begin
1153 anon := false;
1154 with AGrid do
1155 for i := 0 to pred(items.count) do
1156 {begin
1157 pt := cells[12,i];
1158 if pt <> PL_WARD then}
1159 begin
1160 clin := Piece( items[i], U, 11);
1161 if ((clin = '') or (clin = '0')) and (not anon) then
1162 begin
1163 AList.add('-1^<None recorded>'); {add a holder for "no clinic"}
1164 anon := true;
1165 end
1166 else if (clin<>'') and (Alist.indexof(clin)<0) then
1167 Alist.add(clin);
1168 end;
1169 //end;
1170end;
1171
1172procedure LoadFilterList(Alist: TstringList; DestList: TstringList);
1173var
1174 i:integer;
1175begin
1176 for i := 0 to pred(Alist.count) do DestList.add(Piece(Alist[i],u,1));
1177end;
1178
1179procedure ShowFilterStatus(s: string);
1180var
1181 lin:string;
1182begin
1183 if s = PL_OP_VIEW then lin := 'View clinics'
1184 else if s = PL_IP_VIEW then lin := 'View services'
1185 else lin := 'View all problems';
1186 Application.ProcessMessages;
1187end;
1188
1189function ByProvider: string;
1190begin
1191 result := '';
1192 if PLFilters.ProviderList.count > 0 then
1193 if PLFilters.ProviderList[0] <> '0' then result := 'by Provider';
1194end;
1195
1196procedure SetViewFilters(Alist:TStringList);
1197begin
1198 if PLFilters.ProviderList.count = 0 then
1199 PLFilters.ProviderList.add('0'); {default to all provides if none selected}
1200 if PLUser.usCurrentView = PL_OP_VIEW then
1201 begin
1202 if PLFilters.ClinicList.count = 0 then
1203 begin
1204 //GetListforOP(Alist);
1205 LoadFilterList(Alist,PLFilters.ClinicList);
1206 end;
1207 //PostMessage(frmProblems.Handle, UM_PLFILTER,0,0);
1208 end
1209 else if PLUser.usCurrentView = PL_IP_VIEW then
1210 begin
1211 if PLFilters.ServiceList.count=0 then
1212 begin
1213 //GetListforIP(Alist);
1214 LoadFilterList(Alist,PLFilters.ServiceList);
1215 end;
1216 //PostMessage(frmProblems.Handle, UM_PLFILTER,0,0);
1217 end
1218 else {if no default view specified, assumed to be unfiltered}
1219 PlUser.usCurrentView := PL_UF_VIEW;
1220 ShowFilterStatus(PlUser.usCurrentView);
1221end;
1222
1223procedure InitViewFilters(Alist: TstringList);
1224var
1225 i:integer;
1226begin
1227 if PLUser.usCurrentView = '' then PLUser.usCurrentView := PL_UF_VIEW;
1228
1229 if (PLUser.usViewProv = '') or (Piece(PLUser.usViewProv, U, 1) = '0') then
1230 begin
1231 PLFilters.ProviderList.clear;
1232 PLFilters.Providerlist.add('0');
1233 end
1234 else {conserve user preferred provider}
1235 PLFilters.ProviderList.Add(Piece(PLUser.usViewProv, U, 1));
1236
1237 if PLUser.usCurrentView = PL_UF_VIEW then
1238 begin {no filter on patient type, so do routine filter on provider and bail}
1239 SetViewFilters(Alist);
1240 //exit;
1241 end;
1242
1243 if (PLUser.usCurrentView = PL_OP_VIEW) and (PLUser.usViewClin = '') then
1244 begin {no user preferred list of clinics, so get standard list and bail}
1245 SetViewFilters(Alist);
1246 //exit;
1247 end;
1248
1249 if (PLUser.usCurrentView = PL_IP_VIEW) and (PLUser.usViewServ = '') then
1250 begin {no user preferred list of services, so get standard list and bail}
1251 SetViewFilters(Alist);
1252 //exit;
1253 end;
1254
1255 if (PLUser.usCurrentView = PL_OP_VIEW) and (PLUser.usClinList.Count > 0) then
1256 begin {conserve user preferred clinic list}
1257 for i := 0 to pred(PLUser.usClinList.Count) do
1258 PLFilters.ClinicList.add(PLUser.usClinList[i]);
1259 end;
1260
1261 if PLUser.usCurrentView = PL_IP_VIEW then
1262 begin {conserve user preferred service list}
1263 for i := 0 to pred(PLUser.usServList.Count) do
1264 PLFilters.ServiceList.add(PLUser.usServList[i]);
1265 end;
1266
1267// ShowFilterStatus(PlUser.usCurrentView);
1268// PostMessage(frmProblems.Handle, UM_PLFILTER,0,0);
1269end;
1270
1271function ForChars(Num, FontWidth: Integer): Integer;
1272begin
1273 Result := Num * FontWidth;
1274end;
1275
1276procedure GetFontInfo(AHandle: THandle; var FontWidth, FontHeight: Integer);
1277{ pass in a FONT HANDLE & return character width & height }
1278var
1279 DC: HDC;
1280 SaveFont: HFont;
1281 FontMetrics: TTextMetric;
1282 size: TSize ;
1283begin
1284 DC := GetDC(0);
1285 SaveFont := SelectObject(DC, AHandle);
1286 GetTextExtentPoint32(DC, UpperCaseLetters + LowerCaseLetters, 52, size);
1287 FontWidth := size.cx div 52;
1288 GetTextMetrics(DC, FontMetrics);
1289 FontHeight := FontMetrics.tmHeight;
1290 SelectObject(DC, SaveFont);
1291 ReleaseDC(0, DC);
1292end;
1293
1294function ShortDateStrToDate(shortdate: string): string ;
1295{Converts date in format 'mmm dd,yy' or 'mmm dd,yyyy' to standard 'mm/dd/yy'}
1296var
1297 month,day,year: string ;
1298 i: integer ;
1299begin
1300 result := 'ERROR' ;
1301 if ((Pos(' ',shortdate) <> 4) or (Pos(',',shortdate) <> 7)) then exit ; {no spaces or comma}
1302 for i := 1 to 12 do
1303 if Months[i] = UpperCase(Copy(shortdate,1,3)) then month := IntToStr(i);
1304 if month = '' then exit ; {invalid month name}
1305 day := IntToStr(StrToInt(Copy(shortdate,5,2))) ;
1306 year := IntToStr(StrToInt(Copy(shortdate,8,99))) ;
1307 result := month+'/'+day+'/'+year ;
1308end ;
1309
1310(*function NewComment: string ;
1311var
1312 frmProbCmt: TfrmProbCmt ;
1313begin
1314 frmProbCmt := TfrmProbCmt.Create(Application) ;
1315 try
1316 frmProbCmt.Execute;
1317 result := frmProbCmt.CmtResult ;
1318 finally
1319 frmProbCmt.Free ;
1320 end ;
1321end ;
1322
1323function EditComment(OldValue: string): string ;
1324var
1325 frmProbCmt: TfrmProbCmt ;
1326begin
1327 frmProbCmt := TfrmProbCmt.Create(Application) ;
1328 try
1329 frmProbCmt.edComment.Text := Piece(OldValue, U, 2);
1330 frmProbCmt.Execute;
1331 result := frmProbCmt.CmtResult ;
1332 finally
1333 frmProbCmt.Free ;
1334 end ;
1335end ;*)
1336
1337function FixQuotes(InString: string): string;
1338var
1339 i: integer;
1340 OutString: string;
1341begin
1342 OutString := '';
1343 for i := 1 to Length(InString) do
1344 if CharAt(InString, i) = '"' then
1345 OutString := OutString + '""'
1346 else
1347 OutString := OutString + CharAt(InString, i);
1348 Result := OutString;
1349end;
1350
1351end.
Note: See TracBrowser for help on using the repository browser.