source: cprs/branches/tmg-cprs/CPRS-Chart/uProbs.pas@ 711

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

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