Module

uProbs

Path

C:\CPRS\CPRS30\uProbs.pas

Last Modified

7/15/2014 3:26:44 PM

Units Used in Interface

Name Comments
uConst -

Units Used in Implementation

Name Comments
rCore -
uCore -

Classes

Name Comments
TComment -
TCoordExpr -
TKeyVal Key/value -internal/external pairs
TPLFilters Filter lists
TPLPt Patient qualifiers
TPLUserParams User params
TProbRec Problem record

Procedures

Name Owner Declaration Scope Comments
AddNewComment TProbRec procedure AddNewComment(Txt:string); Public -
AddNewCoordExpr TProbRec procedure AddNewCoordExpr(Txt:string); Public -
CreateFields TProbRec Procedure CreateFields; Private -
DHCPtoKeyVal TKeyVal procedure DHCPtoKeyVal(DHCPFld:String); Public -
EraseComments TProbRec Procedure EraseComments(clist:TList); Private -
GetFontInfo - procedure GetFontInfo(AHandle: THandle; var FontWidth, FontHeight: Integer); Interfaced Pass in a FONT HANDLE & return character width & height
GetListforIP - procedure GetListforIP(Alist:TstringList; AGrid: TCaptionListBox); Interfaced -------------------- procedures used in View Filters ----------------------
GetListforOP - procedure GetListforOP(Alist:TstringList; AGrid: TCaptionListBox); Interfaced -
InitViewFilters - procedure InitViewFilters(Alist:TstringList); Interfaced -
LoadComments TProbRec procedure LoadComments; Private -
LoadField TProbRec Procedure LoadField(Fldrec:TKeyVal;Id:String;name:string); Private -
LoadFilterList - procedure LoadFilterList(Alist:TstringList;DestList:TstringList); Interfaced -
SetAOProblem TProbRec Procedure SetAOProblem(value:String); Private -
SetCodeDate TProbRec procedure SetCodeDate(value: TDateTime); Private -
SetCodeDateStr TProbRec procedure SetCodeDateStr(value: String); Private -
SetCondition TProbRec procedure SetCondition(value:String); Private -
SetDate TProbRec procedure SetDate(datefld:TKeyVal;dt:TDateTime); Private -
SetDateString TProbRec procedure SetDateString(df:TKeyVal;value:string); Private
C:char;
  days:longint;
SetEntDate TProbRec procedure SetEntDate(value:TDateTime); Private -
SetEntDatStr TProbRec procedure SetEntDatStr(value:string); Private -
SetENVProblem TProbRec Procedure SetENVProblem(value:String); Private -
SetHNCProblem TProbRec Procedure SetHNCProblem(value:String); Private -
SetModDate TProbRec procedure SetModDate(value:TDateTime); Private -
SetModDatStr TProbRec procedure SetModDatStr(value:string); Private -
SetMSTProblem TProbRec Procedure SetMSTProblem(value:String); Private -
SetNarrative TProbRec procedure SetNarrative(value:TKeyVal); Private -
SetOnsetDate TProbRec procedure SetOnsetDate(value:TDateTime); Private -
SetOnsetDatStr TProbRec procedure SetOnsetDatStr(value:string); Private -
SetPriority TProbRec procedure SetPriority(value:String); Private -
SetRADProblem TProbRec Procedure SetRADProblem(value:String); Private -
SetRECDate TProbRec procedure SetRECDate(value:TDateTime); Private -
SetRecDatStr TProbRec procedure SetRecDatStr(value:string); Private -
SetRESDate TProbRec procedure SetRESDate(value:TDateTime); Private -
SetResDatStr TProbRec procedure SetResDatStr(value:string); Private -
SetSCProblem TProbRec Procedure SetSCProblem(value:String); Private -
SetSHADProblem TProbRec Procedure SetSHADProblem(value:String); Private -
SetStatus TProbRec procedure SetStatus(value:String); Private -
SetViewFilters - procedure SetViewFilters(Alist:TStringList); Interfaced -
ShowFilterStatus - procedure ShowFilterStatus(s: string); Interfaced -

Functions

Name Owner Declaration Scope Comments
ByProvider - function ByProvider:String; Interfaced -
DateStringOK - Function DateStringOK(ds:string):string; Interfaced ----------------------------------- Check Date -------------------------------
FieldChanged TProbRec function FieldChanged(fldName:string):Boolean; Public -
FixQuotes - function FixQuotes(Instring: string): string; Interfaced
Function NewComment: string    ;
function EditComment(OldValue: string): string ;
function NewComment: string ;
var
  frmProbCmt: TfrmProbCmt ;
begin
  frmProbCmt := TfrmProbCmt.Create(Application) ;
  try
    frmProbCmt.Execute;
    result := frmProbCmt.CmtResult ;
  finally
    frmProbCmt.Free ;
  end ;
end ;

function EditComment(OldValue: string): string ;
var
  frmProbCmt: TfrmProbCmt ;
begin
  frmProbCmt := TfrmProbCmt.Create(Application) ;
  try
    frmProbCmt.edComment.Text := Piece(OldValue, U, 2);
    frmProbCmt.Execute;
    result := frmProbCmt.CmtResult ;
  finally
    frmProbCmt.Free ;
  end ;
end ;
ForChars - function ForChars(Num, FontWidth: Integer): Integer; Interfaced -
GetAge TComment function GetAge:boolean; Public/Published -
GetAltFilerObject TProbRec function GetAltFilerObject:TstringList; Private
Return array for filing in dhcp via UPDATE^GMPLUTL
NOTES:
  - leave narrative out, looks like inclusion causes new entry
  - Date recorded (1.09) is non-editable, causes error if present
GetAOProblem TProbRec Function GetAOProblem:String; Private -
GetCodeDate TProbRec function GetCodeDate: TDateTime; Private -
GetCodeDateStr TProbRec function GetCodeDateStr: String; Private -
GetCommentCount TProbRec function GetCommentCount:integer; Private -
GetCondition TProbRec function GetCondition:string; Private -
GetDHCPField TKeyVal function GetDHCPField:string; Public/Published ------------------- TKeyVal Class -----------------
GetEntDate TProbRec function GetEntDate:TDateTime; Private -
GetEntDatstr TProbRec function GetEntDatstr:string; Private -
GetENVProblem TProbRec Function GetENVProblem:String; Private -
GetExtDateAdd TComment function GetExtDateAdd:string; Public/Published -
GetFilerObject TProbRec function GetFilerObject:TstringList; Private
--------------------------------- Filer Objects -------------------------

return array for filing in dhcp
GetGMPDFN TPLPt function GetGMPDFN(dfn:string;name:String):string; Public/Published -
GetHNCProblem TProbRec Function GetHNCProblem:String; Private -
GetModDate TProbRec function GetModDate:TDateTime; Private -
GetModDatstr TProbRec function GetModDatstr:string; Private -
GetMSTProblem TProbRec Function GetMSTProblem:String; Private -
GetOnsetDate TProbRec function GetOnsetDate:TDateTime; Private -
GetOnsetDatstr TProbRec function GetOnsetDatstr:string; Private -
GetOrigVal - function GetOrigVal(id:string):string; Local -
GetPriority TProbRec function GetPriority:String; Private -
GetRADProblem TProbRec Function GetRADProblem:String; Private -
GetRECDate TProbRec function GetRECDate:TDateTime; Private -
GetRecDatstr TProbRec function GetRecDatstr:string; Private -
GetRESDate TProbRec function GetRESDate:TDateTime; Private -
GetResDatstr TProbRec function GetResDatstr:string; Private -
GetSCProblem TProbRec Function GetSCProblem:String; Private -
GetSHADProblem TProbRec Function GetSHADProblem:String; Private -
GetStatus TProbRec function GetStatus:String; Private -
GetTDateTime TProbRec function GetTDateTime(dt:string):TDateTime; Private -
ShortDateStrToDate - function ShortDateStrToDate(shortdate: string): string ; Interfaced Converts date in format 'mmm dd,yy' or 'mmm dd,yyyy' to standard 'mm/dd/yy'
StripSpace - Function StripSpace(str:string):string; Interfaced -
TComtoDHCPCom TComment function TComtoDHCPCom:string; Public/Published -
TCoordExprtoDHCPCoordExpr TCoordExpr function TCoordExprtoDHCPCoordExpr: String; Public/Published -
Today TPLPt function Today:string; Public/Published Returns string in DHCP^mmm dd yyyy format

Global Variables

Name Type Declaration Comments
NTRTComment UnicodeString NTRTComment :String; -
PLFilters TPLFilters PLFilters :TPLFilters; -
PLProblem UnicodeString PLProblem :string; {this is problem selected from lexicon lookup form} This is problem selected from lexicon lookup form
PLPt TPLPt PLPt :TPLPt; -
PLUser TPLUserParams PLUser :TPLUserParams; -
pProviderID Int64 pProviderID :int64; {this is provider reviewing record, not resp provider} This is provider reviewing record, not resp provider
pProviderName UnicodeString pProviderName :string; {ditto} Ditto
ProbRec TProbRec ProbRec :TProbRec; -
RequestNTRT Boolean RequestNTRT :Boolean; -

Constants

Name Declaration Scope Comments
ACTIVE_LIST_CAP 'Active Problems' Interfaced -
BOTH_LIST_CAP 'Active and Inactive Problems' Interfaced -
fComStart 4 Interfaced -
INACTIVE_LIST_CAP 'Inactive Problems' Interfaced -
Months array[1..12] of string[3] = ('JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC') Global -
PL_CLINIC char ='C' Interfaced -
PL_IP_VIEW char = 'S' Interfaced -
PL_OP_VIEW char = 'C' Interfaced -
PL_UF_VIEW char = 'U' Interfaced -
PL_WARD char='W' Interfaced -
REMOVED_LIST_CAP 'Removed Problems' Interfaced -
v char = #254 Interfaced -


Module Source

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

Module Calls (2 levels)


uProbs
 ├uConst
 ├rCore
 │ └uCore
 └uCore...

Module Called-By (2 levels)


                 uProbs
              fPCELex┤ 
  fBALocalDiagnoses┤ │ 
         fDiagnoses┤ │ 
       fPCEBaseMain┤ │ 
fBAOptionsDiagnoses┤ │ 
         fODConsult┤ │ 
            fODProc┤ │ 
          fEditProc┤ │ 
       fEditConsult┘ │ 
        fDiagnoses...┤ 
               fProbs┤ 
             fFrame┤ │ 
           fProbEdt┤ │ 
           fProbflt┤ │ 
           fProbLex┘ │ 
          fProbEdt...┤ 
          fProbflt...┤ 
          fProbLex...┤ 
        fProbFreetext┘ 
          CPRSChart┤   
        fProbLex...┘