source: cprs/branches/tmg-cprs/CPRS-Chart/uEventHooks.pas@ 1619

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

Initial upload of TMG-CPRS 1.0.26.69

File size: 17.2 KB
RevLine 
[453]1//kt -- Modified with SourceScanner on 8/21/2007
2unit uEventHooks;
3
4interface
5
6uses SysUtils, Classes, Windows, Dialogs, Forms, ComObj, ActiveX,
7 CPRSChart_TLB, ORNet, ORFn, uCore;
8
9type
10 TCPRSExtensionData = record
11 Data1: string;
12 Data2: string;
13 end;
14
15procedure RegisterCPRSTypeLibrary;
16procedure ProcessPatientChangeEventHook;
17function ProcessOrderAcceptEventHook(OrderID: string; DisplayGroup: integer): boolean;
18procedure GetCOMObjectText(COMObject: integer; const Param2, Param3: string;
19 var Data1, Data2: string);
20function COMObjectOK(COMObject: integer): boolean;
21function COMObjectActive: boolean;
22
23implementation
24
25uses
26 Trpcb, rEventHooks,
27 DKLang //kt
28 ;
29
30type
31 ICPRSBrokerInitializer = interface(ICPRSBroker)
32 procedure Initialize;
33 end;
34
35 TCPRSBroker = class(TAutoIntfObject, ICPRSBrokerInitializer)
36 private
37 FContext: string;
38 FRPCVersion: string;
39 FClearParameters: boolean;
40 FClearResults: boolean;
41 FResults: string;
42 FParam: TParams;
43 FEmptyParams: TParams;
44 public
45 constructor Create;
46 destructor Destroy; override;
47 procedure Initialize;
48 function SetContext(const Context: WideString): WordBool; safecall;
49 function Server: WideString; safecall;
50 function Port: Integer; safecall;
51 function DebugMode: WordBool; safecall;
52 function Get_RPCVersion: WideString; safecall;
53 procedure Set_RPCVersion(const Value: WideString); safecall;
54 function Get_ClearParameters: WordBool; safecall;
55 procedure Set_ClearParameters(Value: WordBool); safecall;
56 function Get_ClearResults: WordBool; safecall;
57 procedure Set_ClearResults(Value: WordBool); safecall;
58 procedure CallRPC(const RPCName: WideString); safecall;
59 function Get_Results: WideString; safecall;
60 procedure Set_Results(const Value: WideString); safecall;
61 function Get_Param(Index: Integer): WideString; safecall;
62 procedure Set_Param(Index: Integer; const Value: WideString); safecall;
63 function Get_ParamType(Index: Integer): BrokerParamType; safecall;
64 procedure Set_ParamType(Index: Integer; Value: BrokerParamType); safecall;
65 function Get_ParamList(Index: Integer; const Node: WideString): WideString; safecall;
66 procedure Set_ParamList(Index: Integer; const Node: WideString; const Value: WideString); safecall;
67 function ParamCount: Integer; safecall;
68 function ParamListCount(Index: Integer): Integer; safecall;
69 property RPCVersion: WideString read Get_RPCVersion write Set_RPCVersion;
70 property ClearParameters: WordBool read Get_ClearParameters write Set_ClearParameters;
71 property ClearResults: WordBool read Get_ClearResults write Set_ClearResults;
72 property Results: WideString read Get_Results write Set_Results;
73 property Param[Index: Integer]: WideString read Get_Param write Set_Param;
74 property ParamType[Index: Integer]: BrokerParamType read Get_ParamType write Set_ParamType;
75 property ParamList[Index: Integer; const Node: WideString]: WideString read Get_ParamList write Set_ParamList;
76 end;
77
78 TCPRSState = class(TAutoIntfObject, ICPRSState)
79 private
80 FHandle: string;
81 public
82 constructor Create;
83 function Handle: WideString; safecall;
84 function UserDUZ: WideString; safecall;
85 function UserName: WideString; safecall;
86 function PatientDFN: WideString; safecall;
87 function PatientName: WideString; safecall;
88 function PatientDOB: WideString; safecall;
89 function PatientSSN: WideString; safecall;
90 function LocationIEN: Integer; safecall;
91 function LocationName: WideString; safecall;
92 end;
93
94 TCPRSEventHookManager = class(TObject)
95 private
96 FCPRSBroker: ICPRSBrokerInitializer;
97 FCPRSState: ICPRSState;
98 FErrors: TStringList;
99 FLock: TRTLCriticalSection;
100 public
101 constructor Create;
102 destructor Destroy; override;
103 function ProcessComObject(const GUIDString: string;
104 const AParam2, AParam3: string;
105 var Data1, Data2: WideString): boolean;
106 procedure EnterCriticalSection;
107 procedure LeaveCriticalSection;
108 end;
109
110
111var
112 uCPRSEventHookManager: TCPRSEventHookManager = nil;
113 uCOMObjectActive: boolean = False;
114
115procedure EnsureEventHookObjects;
116begin
117 if not assigned(uCPRSEventHookManager) then
118 uCPRSEventHookManager := TCPRSEventHookManager.Create;
119end;
120
121{ TCPRSBroker }
122
123constructor TCPRSBroker.Create;
124var
125 CPRSLib: ITypeLib;
126
127begin
128 FParam := TParams.Create(nil);
129 FEmptyParams := TParams.Create(nil);
130 OleCheck(LoadRegTypeLib(LIBID_CPRSChart, 1, 0, 0, CPRSLib));
131 inherited Create(CPRSLib, ICPRSBroker);
132 EnsureBroker;
133end;
134
135procedure TCPRSBroker.CallRPC(const RPCName: WideString);
136var
137 err: boolean;
138 tmpRPCVersion: string;
139 tmpClearParameters: boolean;
140 tmpClearResults: boolean;
141 tmpResults: string;
142 tmpParam: TParams;
143
144begin
145 EnsureEventHookObjects;
146 uCPRSEventHookManager.EnterCriticalSection;
147 try
148 err := (FContext = '');
149 if(not err) then
150 err := not UpdateContext(FContext);
151 if (not err) then
152 err := IsBaseContext;
153 if err then
154 raise EOleException.Create('Invalid Broker Context', OLE_E_FIRST, Application.ExeName ,'', 0)
155 else
156 begin
157 if RPCName <> '' then
158 begin
159 tmpRPCVersion := RPCBrokerV.RpcVersion;
160 tmpClearParameters := RPCBrokerV.ClearParameters;
161 tmpClearResults := RPCBrokerV.ClearResults;
162 tmpResults := RPCBrokerV.Results.Text;
163 tmpParam := TParams.Create(nil);
164 try
165 RPCBrokerV.RemoteProcedure := RPCName;
166 RPCBrokerV.RpcVersion := FRPCVersion;
167 RPCBrokerV.ClearParameters := FClearParameters;
168 RPCBrokerV.ClearResults := FClearResults;
169 RPCBrokerV.Param.Assign(FParam);
170 CallBrokerInContext;
171 FParam.Assign(RPCBrokerV.Param);
172 FResults := RPCBrokerV.Results.Text;
173 finally
174 RPCBrokerV.RpcVersion := tmpRPCVersion;
175 RPCBrokerV.ClearParameters := tmpClearParameters;
176 RPCBrokerV.ClearResults := tmpClearResults;
177 RPCBrokerV.Results.Text := tmpResults;
178 RPCBrokerV.Param.Assign(tmpParam);
179 tmpParam.Free;
180 end;
181 end
182 else
183 begin
184 RPCBrokerV.Results.Clear;
185 FResults := '';
186 end;
187 end;
188 finally
189 uCPRSEventHookManager.LeaveCriticalSection;
190 end;
191end;
192
193function TCPRSBroker.DebugMode: WordBool;
194begin
195 Result := RPCBrokerV.DebugMode;
196end;
197
198function TCPRSBroker.Get_ClearParameters: WordBool;
199begin
200 Result := FClearParameters;
201end;
202
203function TCPRSBroker.Get_ClearResults: WordBool;
204begin
205 Result := FClearResults;
206end;
207
208function TCPRSBroker.Get_Param(Index: Integer): WideString;
209begin
210 Result := FParam[Index].Value;
211end;
212
213function TCPRSBroker.Get_ParamList(Index: Integer;
214 const Node: WideString): WideString;
215begin
216 Result := FParam[Index].Mult[Node];
217end;
218
219function TCPRSBroker.Get_ParamType(Index: Integer): BrokerParamType;
220begin
221 case FParam[Index].PType of
222 literal: Result := bptLiteral;
223 reference: Result := bptReference;
224 list: Result := bptList;
225 else Result := bptUndefined;
226 end;
227end;
228
229function TCPRSBroker.Get_Results: WideString;
230begin
231 Result := FResults;
232end;
233
234function TCPRSBroker.Get_RPCVersion: WideString;
235begin
236 Result := FRPCVersion;
237end;
238
239function TCPRSBroker.ParamCount: Integer;
240begin
241 Result := FParam.Count;
242end;
243
244function TCPRSBroker.ParamListCount(Index: Integer): Integer;
245begin
246 Result := FParam[Index].Mult.Count;
247end;
248
249function TCPRSBroker.Port: Integer;
250begin
251 Result := RPCBrokerV.ListenerPort;
252end;
253
254function TCPRSBroker.Server: WideString;
255begin
256 Result := RPCBrokerV.Server;
257end;
258
259procedure TCPRSBroker.Set_ClearParameters(Value: WordBool);
260begin
261 FClearParameters := Value;
262end;
263
264procedure TCPRSBroker.Set_ClearResults(Value: WordBool);
265begin
266 FClearResults := Value;
267end;
268
269procedure TCPRSBroker.Set_Param(Index: Integer; const Value: WideString);
270begin
271 FParam[Index].Value := Value;
272end;
273
274procedure TCPRSBroker.Set_ParamList(Index: Integer; const Node,
275 Value: WideString);
276begin
277 FParam[Index].Mult[Node] := Value;
278end;
279
280procedure TCPRSBroker.Set_ParamType(Index: Integer;
281 Value: BrokerParamType);
282begin
283 case Value of
284 bptLiteral: FParam[Index].PType := literal;
285 bptReference: FParam[Index].PType := reference;
286 bptList: FParam[Index].PType := list;
287 else FParam[Index].PType := undefined;
288 end;
289end;
290
291procedure TCPRSBroker.Set_Results(const Value: WideString);
292begin
293 FResults := Value;
294end;
295
296procedure TCPRSBroker.Set_RPCVersion(const Value: WideString);
297begin
298 FRPCVersion := Value;
299end;
300
301function TCPRSBroker.SetContext(const Context: WideString): WordBool;
302begin
303 FContext := Context;
304 Result := UpdateContext(FContext);
305end;
306
307procedure TCPRSBroker.Initialize;
308begin
309 FContext := '';
310 FRPCVersion := RPCBrokerV.RpcVersion;
311 FClearParameters := RPCBrokerV.ClearParameters;
312 FClearResults := RPCBrokerV.ClearResults;
313 FResults := '';
314 FParam.Assign(FEmptyParams);
315end;
316
317destructor TCPRSBroker.Destroy;
318begin
319 FParam.Free;
320 FEmptyParams.Free;
321 inherited;
322end;
323
324{ TCPRSState }
325
326constructor TCPRSState.Create;
327var
328 CPRSLib: ITypeLib;
329
330begin
331 OleCheck(LoadRegTypeLib(LIBID_CPRSChart, 1, 0, 0, CPRSLib));
332 inherited Create(CPRSLib, ICPRSState);
333 FHandle := DottedIPStr + 'x' + IntToHex(Application.Handle,8);
334end;
335
336function TCPRSState.Handle: WideString;
337begin
338 Result := FHandle;
339end;
340
341function TCPRSState.LocationIEN: Integer;
342begin
343 Result := Encounter.Location;
344end;
345
346function TCPRSState.LocationName: WideString;
347begin
348 Result := Encounter.LocationName;
349end;
350
351function TCPRSState.PatientDFN: WideString;
352begin
353 Result := Patient.DFN;
354end;
355
356function TCPRSState.PatientDOB: WideString;
357begin
358 Result := FormatFMDateTime('mm/dd/yyyy', Patient.DOB);
359end;
360
361function TCPRSState.PatientName: WideString;
362begin
363 Result := Patient.Name;
364end;
365
366function TCPRSState.PatientSSN: WideString;
367begin
368 Result := Patient.SSN;
369end;
370
371function TCPRSState.UserDUZ: WideString;
372begin
373 Result := IntToStr(User.DUZ);
374end;
375
376function TCPRSState.UserName: WideString;
377begin
378 Result := User.Name;
379end;
380
381{ TCPRSEventHookManager }
382
383constructor TCPRSEventHookManager.Create;
384begin
385 inherited;
386 FCPRSBroker := TCPRSBroker.Create;
387 FCPRSState := TCPRSState.Create;
388end;
389
390destructor TCPRSEventHookManager.Destroy;
391begin
392 FCPRSState := nil;
393 FCPRSBroker := nil;
394 if assigned(FErrors) then
395 FErrors.Free;
396 inherited;
397end;
398
399procedure TCPRSEventHookManager.EnterCriticalSection;
400begin
401 Windows.EnterCriticalSection(FLock);
402end;
403
404procedure TCPRSEventHookManager.LeaveCriticalSection;
405begin
406 Windows.LeaveCriticalSection(FLock);
407end;
408
409function TCPRSEventHookManager.ProcessComObject(const GUIDString: string;
410 const AParam2, AParam3: string;
411 var Data1, Data2: WideString): boolean;
412var
413 ObjIEN, ObjName, ObjGUIDStr, err, AParam1: string;
414 ObjGUID: TGUID;
415 ObjIntf: IUnknown;
416 Obj: ICPRSExtension;
417
418begin
419 Result := FALSE;
420 ObjIEN := Piece(GUIDString,U,1);
421 if assigned(FErrors) and (FErrors.IndexOf(ObjIEN) >= 0) then exit;
422 ObjName := Piece(GUIDString,U,2);
423 ObjGUIDStr := Piece(GUIDString,U,3);
424 if (ObjGUIDStr <> '') then
425 begin
426 try
427 ObjGUID := StringToGUID(ObjGUIDStr);
428 try
429 ObjIntf := CreateComObject(ObjGUID);
430 if assigned(ObjIntf) then
431 begin
432 try
433 ObjIntf.QueryInterface(IID_ICPRSExtension, Obj);
434 if assigned(Obj) then
435 begin
436 AParam1 := Piece(GUIDString,U,5);
437 InitializeCriticalSection(FLock);
438 try
439 FCPRSBroker.Initialize;
440 uCOMObjectActive := True;
441 Result := Obj.Execute(FCPRSBroker, FCPRSState,
442 AParam1, AParam2, AParam3, Data1, Data2);
443 finally
444 DeleteCriticalSection(FLock);
445 uCOMObjectActive := False;
446 end;
447 end
448 else
449// err := 'COM Object ' + ObjName + ' does not support ICPRSExtension'; <-- original line. //kt 8/21/2007
450 err := DKLangConstW('uEventHooks_COM_Object')+' ' + ObjName + DKLangConstW('uEventHooks_does_not_support_ICPRSExtension'); //kt added 8/21/2007
451 except
452// err := 'Error executing ' + ObjName; <-- original line. //kt 8/21/2007
453 err := DKLangConstW('uEventHooks_Error_executing')+' ' + ObjName; //kt added 8/21/2007
454 end;
455 end;
456 except
457// err := 'COM Object ' + ObjName + ' not found on this workstation.'; <-- original line. //kt 8/21/2007
458 err := DKLangConstW('uEventHooks_COM_Object')+' ' + ObjName + DKLangConstW('uEventHooks_not_found_on_this_workstationx'); //kt added 8/21/2007
459 end;
460 except
461// err := 'COM Object ' + ObjName + ' has an invalid GUID' + CRLF + ObjGUIDStr; <-- original line. //kt 8/21/2007
462 err := DKLangConstW('uEventHooks_COM_Object')+' ' + ObjName + DKLangConstW('uEventHooks_has_an_invalid_GUID') + CRLF + ObjGUIDStr; //kt added 8/21/2007
463 end;
464 if err <> '' then
465 begin
466 if not assigned(FErrors) then
467 FErrors := TStringList.Create;
468 if FErrors.IndexOf(ObjIEN) < 0 then
469 FErrors.Add(ObjIEN);
470 ShowMessage(err);
471 end;
472 end;
473end;
474
475procedure FreeEventHookObjects;
476begin
477 FreeAndNil(uCPRSEventHookManager);
478end;
479
480// External Calls
481
482procedure RegisterCPRSTypeLibrary;
483type
484 TUnregisterProc = function(const GUID: TGUID; VerMajor, VerMinor: Word;
485 LCID: TLCID; SysKind: TSysKind): HResult stdcall;
486
487var
488 Unregister: boolean;
489 CPRSLib: ITypeLib;
490 DoHalt: boolean;
491 ModuleName: string;
492 HelpPath: WideString;
493 Buffer: array[0..261] of Char;
494 Handle: THandle;
495 UnregisterProc: TUnregisterProc;
496 LibAttr: PTLibAttr;
497
498begin
499 DoHalt := TRUE;
500 if FindCmdLineSwitch('UNREGSERVER', ['-', '/'], True) then
501 Unregister := TRUE
502 else
503 begin
504 Unregister := FALSE;
505 if not FindCmdLineSwitch('REGSERVER', ['-', '/'], True) then
506 DoHalt := FALSE;
507 end;
508
509 try
510 SetString(ModuleName, Buffer, Windows.GetModuleFileName(HInstance, Buffer, SizeOf(Buffer)));
511 if ModuleName <> '' then
512 begin
513 OleCheck(LoadTypeLib(PWideChar(WideString(ModuleName)), CPRSLib)); // will register if needed
514 if assigned(CPRSLib) then
515 begin
516 if Unregister then
517 begin
518 Handle := GetModuleHandle('OLEAUT32.DLL');
519 if Handle <> 0 then
520 begin
521 @UnregisterProc := GetProcAddress(Handle, 'UnRegisterTypeLib');
522 if @UnregisterProc <> nil then
523 begin
524 OleCheck(CPRSLib.GetLibAttr(LibAttr));
525 try
526 with LibAttr^ do
527 UnregisterProc(guid, wMajorVerNum, wMinorVerNum, lcid, syskind);
528 finally
529 CPRSLib.ReleaseTLibAttr(LibAttr);
530 end;
531 end;
532 end;
533 end
534 else
535 begin
536 HelpPath := ExtractFilePath(ModuleName);
537 OleCheck(RegisterTypeLib(CPRSLib, PWideChar(WideString(ModuleName)), PWideChar(HelpPath)));
538 end;
539 end;
540 end;
541 except
542// ignore any errors
543 end;
544 if DoHalt then Halt;
545end;
546
547procedure ProcessPatientChangeEventHook;
548var
549 d1, d2: WideString;
550 COMObj: string;
551
552begin
553 COMObj := GetPatientChangeGUIDs;
554 if(COMObj <> '') and (COMObj <> '0') then
555 begin
556 EnsureEventHookObjects;
557 d1 := '';
558 d2 := '';
559 uCPRSEventHookManager.ProcessComObject(COMObj, 'P=' + Patient.DFN, '', d1, d2);
560 end;
561end;
562
563function ProcessOrderAcceptEventHook(OrderID: string; DisplayGroup: integer): boolean;
564var
565 d1, d2: WideString;
566 COMObj: string;
567
568begin
569 Result := False;
570 COMObj := GetOrderAcceptGUIDs(DisplayGroup);
571 if(COMObj <> '') and (COMObj <> '0') then
572 begin
573 EnsureEventHookObjects;
574 d1 := '';
575 d2 := '';
576 //Result will be set to True by Com object if the order is deleted by LES
577 Result := uCPRSEventHookManager.ProcessComObject(COMObj, 'O=' + OrderID, '', d1, d2);
578 end;
579end;
580
581procedure GetCOMObjectText(COMObject: integer; const Param2, Param3: string;
582 var Data1, Data2: string);
583var
584 d1, d2: WideString;
585 COMObj: string;
586
587begin
588 if COMObject > 0 then
589 begin
590 COMObj := GetCOMObjectDetails(COMObject);
591 if(COMObj <> '') and (COMObj <> '0') then
592 begin
593 EnsureEventHookObjects;
594 d1 := Data1;
595 d2 := Data2;
596 if uCPRSEventHookManager.ProcessComObject(COMObj, Param2, Param3, d1, d2) then
597 begin
598 Data1 := d1;
599 Data2 := d2;
600 end;
601 end;
602 end;
603end;
604
605function COMObjectOK(COMObject: integer): boolean;
606begin
607 if assigned(uCPRSEventHookManager) and assigned(uCPRSEventHookManager.FErrors) then
608 Result := (uCPRSEventHookManager.FErrors.IndexOf(IntToStr(COMObject)) < 0)
609 else
610 Result := TRUE;
611end;
612
613function COMObjectActive: boolean;
614begin
615 Result := uCOMObjectActive;
616end;
617
618initialization
619
620finalization
621 FreeEventHookObjects;
622
623end.
Note: See TracBrowser for help on using the repository browser.