source: cprs/trunk/CPRS-Chart/uEventHooks.pas@ 486

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

Initial Upload of Official WV CPRS 1.0.26.76

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