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

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

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