source: cprs/branches/tmg-cprs/CPRS-Chart/BA/UBACore.pas@ 1085

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

Initial upload of TMG-CPRS 1.0.26.69

File size: 47.4 KB
Line 
1//kt -- Modified with SourceScanner on 8/8/2007
2unit UBACore;
3
4{.$define debug}
5
6interface
7uses
8 Classes, ORNet, uConst, ORFn, Sysutils, Dialogs, Windows,Messages, UBAGlobals,Trpcb,
9 fFrame;
10
11function rpcAddToPersonalDxList(UserDUZ:int64; DxCodes:TStringList):boolean;
12function rpcGetPersonalDxList(UserDUZ:int64):TStringList;
13function rpcDeleteFromPersonalDxList(UserDUZ:int64; Dest:TStringList):integer;
14procedure rpcSaveBillingDxEntered; // save dx enteries regardless of being mandatory....
15function rpcNonBillableOrders(pOrderList: TStringList): TStringList;
16function rpcOrderRequiresDx(pList: TStringList):boolean;
17procedure rpcSetBillingAwareSwitch(encProvider: int64; pPatientDFN: string);
18procedure rpcGetProviderPatientDaysDx(ProviderIEN: string;PatientIEN: string);
19procedure rpcGetSC4Orders; // returns Eligible Treatment Factors for a given patient
20
21function rpcTreatmentFactorsActive(pOrderID: string):boolean;
22procedure rpcBuildSCIEList(pOrderList: TList);
23function rpcGetUnsignedOrdersBillingData(pOrderList: TStringList):TStringList;
24function rpcRetrieveSelectedOrderInfo(pOrderIDList: TStringList):TStringList;
25function rpcGetTFHintData:TStringList;
26procedure rpcSaveNurseConsultOrder(pOrderRec:TStringList);
27function rpcGetBAMasterSwStatus:boolean;
28procedure rpcSaveCIDCData(pCIDCList: TStringList);
29function rpcIsPatientInsured(pPatientDFN: string):boolean;
30
31procedure SaveBillingData(pBillingData:TStringList);
32function OrdersHaveDx(pOrderList:TStringList):boolean;
33procedure SetTreatmentFactors(TFactors: string);
34function AttachDxToOrderList(pOrderList:TStringList):TStringList;
35procedure AttachPLTFactorsToDx(var Dest:String;ProblemRec:string);
36procedure BALoadStsFlagsAsIs(StsFlagsIN: string);
37function BADxEntered:boolean; // main logic to determine if dx has been entered for order that requires dx
38function StripTFactors(FactorsIN: string): string;
39function AddProviderPatientDaysDx(Dest: TStringList; ProviderIEN: string;PatientIEN: string) : TStringList;
40function IsOrderBillable(pOrderID: string):boolean;
41
42function OrderRequiresSCEI(pOrderID :String): boolean;
43procedure SaveUnsignedOrders(pOrderRec:String);
44
45procedure CompleteUnsignedBillingInfo(pOrderList: TStringList);
46procedure BuildSaveUnsignedList(pOrderList: TStringList);
47procedure LoadUnsignedOrderRec(var thisRetVal: TBAUnsignedBillingRec;UnsignedBillingInfo:string);
48function GetUnsignedOrderFlags(pOrderID: string; pFlagList: TStringList):string; // returns STSFlags if found
49procedure BuildTFHintRec;
50function IsAllOrdersNA(pOrderList:TStringList):boolean;
51function PrepOrderID(pOrderID:String): String;
52procedure ClearSelectedOrderDiagnoses(pOrderIDList: TStringList);
53procedure LoadConsultOrderRec(var thisRetVal: TBAConsultOrderRec; pOrderID: String; pDxList: TStringList);
54procedure CompleteConsultOrderRec(pOrderID: string; pDxList: TStringList);
55function GetConsultFlags(pOrderID:String; pFlagList:TStringList;FlagsAsIs:string):string;
56function SetConsultFlags(pPLFactors: string;pFlagsAsIs: string):string; // return updated flags.
57procedure GetBAStatus(pProvider:int64; pPatientDFN: string);
58function IsICD9CodeActive(ACode: string; LexApp: string; ADate:TFMDateTime = 0): boolean;
59function BuildConsultDxRec(ConsultRec: TBAConsultOrderRec): string;
60function ConvertPIMTreatmentFactors(pTFactors:string):string;
61procedure DeleteDCOrdersFromCopiedList(pOrderID:string);
62procedure UpdateBAConsultOrderList(pDcOrders: TStringList);
63function VerifyOrderIdExists(pOrderList: TStringList): TStringList; // removes records without order id
64function IsCIDCProvider(encProvider:int64):boolean;
65function ProcessProblemTFactors(pText:String):String;
66
67var
68 uAddToPDl: integer;
69 uDeleteFromPDL: integer;
70 uDxLst: TStringList;
71 BADxList: TStringList;
72
73implementation
74
75uses fBALocalDiagnoses, fOrdersSign, fReview, rOrders, uCore, rCore, rPCE,uPCE,
76 UBAConst, UBAMessages, USignItems;
77
78
79// ----------------- MAIN CIDC DX HAS BEEN ENTERED LOGIC ---------------------------
80function BADxEntered:boolean;
81var
82 i: integer;
83 //orderStatus: integer;
84 x: string;
85 passList: TStringList;
86 holdOrderList: TStringList;
87 thisOrderID: string;
88 thisRec: string;
89begin
90 // Result := TRUE; // caused hint.....
91 holdOrderList := TStringList.Create;
92 holdOrderList.Clear;
93 updatedBAOrderList := TStringList.Create;
94 updatedBAOrderList.Clear;
95 passList := TStringList.Create;
96 passList.Clear;
97 // determine which orders require a dx (lrmp- only)
98 // if NO then continue
99 // if YES, check BADxList for orders with DX enteries.
100 // if ok then create data string pass to M via RPC
101
102 for i := 0 to BAOrderList.Count-1 do
103 begin
104 thisRec := BAOrderList.Strings[i];
105 thisOrderID := piece(thisRec,';',1) + ';1'; //rebuild orderID pass to M.
106 x := BAOrderList.Strings[i];
107 //orderStatus := StrToInt(CharAt(Piece(x, ';', 2), 1)); // Order Status 1=OK, 2=DISCONTINUE
108 if IsOrderBillable(thisOrderID) then
109 begin
110 passList.Add(piece(x,';',1));
111 holdOrderList.Add(x);// place holder for orders that can be signed!
112 end;
113 end;
114
115 BAOrderList.Assign(holdOrderList); //assign signable orders to BAOrderList for further processing
116 holdOrderList.Clear; // CQ5025
117
118 //call with passList determine if LRMP
119 if rpcOrderRequiresDx(passList) then
120 BAOrderList.Assign(updatedBAOrderList);
121
122 // check of all orders dx columns are flagged with N/A.....
123 if UBACore.IsAllOrdersNA(BAOrderList) then
124 begin
125 Result := TRUE; // force true, no record needs DX entry
126 Exit; //to do. clean this up... when time permitts
127 end
128 else
129 begin
130 if OrdersHaveDx(UBAGlobals.BAOrderList) then
131 begin
132 Result := True; // CIDC orders have dx
133 SaveBillingData(UBAGlobals.BAOrderList) ;
134 end
135 else
136 begin
137 Result := FALSE;
138 Exit;
139 end;
140 end;
141end;
142
143
144function rpcOrderRequiresDx(pList: TStringList):boolean;
145var x: string;
146 i,j: integer;
147 returnList, updatedList: TStringList;
148 begin
149 Result := FALSE; // initial set dx NOT required
150 returnList := TStringList.Create;
151 updatedList := TStringList.Create;
152 returnList.Clear;
153 updatedList.Clear;
154 // remove deleted orderid's
155 if UBAGlobals.BADeltedOrders.Count > 0 then
156 begin
157 for i := 0 to UBAGlobals.BADeltedOrders.Count-1 do
158 x := UBAGlobals.BADeltedOrders.Strings[i];
159 for j := 0 to pList.Count-1 do
160 begin
161 if x = pList.Strings[j] then
162 continue // orderid is removed.. or skipped
163 else
164 updatedList.Add(x);
165 end;
166 end
167 else
168 updatedList.Assign(pList);
169
170 // call returns boolean, orders is billable=1 or nonbillable=0 or discontinued = 0
171 tCallV(returnList,'ORWDBA1 ORPKGTYP',[updatedList]);
172
173 //Remove NON LRMP orders from the mix(when checking for dx entry);
174 // BAOrderList and pList are in sync - order id....
175 for i := 0 to BAOrderList.Count-1 do
176 begin
177 x:= piece(returnList.Strings[i],'^',1);
178 if x = BILLABLE_ORDER then
179 begin
180 updatedBAOrderList.Add(BAOrderList[i]);
181 Result := TRUE;
182 end;
183 end;
184end;
185
186
187// UBAGlobals.NonBillableOrderList must be populated prior to calling this function.
188// call rpcNonBillableOrders to populate List.
189function IsOrderBillable(pOrderID: string):boolean ;
190var
191 i: integer;
192 currOrderID: string;
193 matchOrderID : string;
194
195begin
196 Result := TRUE; // = Billable
197 currOrderID := PrepOrderID(pOrderID);
198 if Piece(pOrderID,';',2) = DISCONTINUED_ORDER THEN
199 begin
200 Result := FALSE;
201 Exit;
202 end;
203 try
204 for i := 0 to UBAGlobals.NonBillableOrderList.Count -1 do
205 begin
206 matchOrderID := PrepOrderID( (Piece(UBAGlobals.NonBillableOrderList.Strings[i],U,1)) );
207 if currOrderID = matchOrderID then
208 begin
209 Result := FALSE; //= Non Billable
210 Exit;
211 end;
212 end;
213 except
214 on EListError do
215 begin
216 {$ifdef debug}ShowMessage('EListError in UBACore.IsOrderBillable()');{$endif}
217 raise;
218 end;
219 end;
220end;
221
222
223procedure SaveBillingData(pBillingData:TStringList);
224var
225 RecsToSave: TStringList;
226begin
227 RecsToSave := TStringList.Create;
228 RecsToSave.Clear;
229
230 RecsToSave := AttachDxToOrderList(pBillingData); //call with new Biling data, return-code returned
231 rpcSaveCIDCData(RecsToSave); // verify and save billing data
232
233 if Assigned(UBAGlobals.BAOrderList) then UBAGlobals.BAOrderList.Clear; // hds00005025
234end;
235
236function rpcTreatmentFactorsActive(pOrderID:string): boolean;
237var x: string;
238 i: integer;
239 pList: TStringList;
240 rList: TStringList;
241 begin
242 pList := TStringList.Create;
243 rList := TStringList.Create;
244 rList.Clear;
245 rList := nil;
246 pList.Clear;
247 pList.Add(pOrderID);
248 Result := FALSE;
249 // call returns boolean, orders is billable=1 or nonbillable=0 or discontinued = 0
250 tCallV(rList,'ORWDBA1 ORPKGTYP',[pList]);
251 //returns boolean value by OrderID - True = billable
252 for i := 0 to rList.Count-1 do
253 begin
254 x := rList[i];
255 if rList[i] = BILLABLE_ORDER then
256 begin
257 Result := True;
258 end;
259 end;
260end;
261
262
263function AttachDxToOrderList(pOrderList:TStringList):TStringList;
264var
265 i: integer;
266 newBillingList: TStringList;
267 baseDxRec: TBADxRecord;
268 currentOrderID: string;
269 currentOrderString: string;
270 dxString,FlagsStatsIn: string;
271
272begin
273 newBillingList:= TStringList.Create;
274 newBillingList.Clear;
275 dxString := '';
276 baseDxRec := nil;
277 baseDxRec := TBADxRecord.Create;
278
279 InitializeNewDxRec(baseDxRec);
280 for i := 0 to pOrderList.Count-1 do
281 begin
282 currentOrderString := pOrderList.Strings[i];
283 currentOrderID := piece(pOrderList.Strings[i],';',1)+ ';1';
284
285 GetBADxListForOrder(baseDxRec, currentOrderID);
286 FlagsStatsIn := BAFlagsIN;
287 dxString := currentOrderString + '^' + piece(baseDxRec.FBADxCode,':',2);
288 if baseDxRec.FBASecDx1 <> '' then
289 dxString := dxString + '^' + piece(baseDxRec.FBASecDx1,':',2);
290 if baseDxRec.FBASecDx2 <> '' then
291 dxString := dxString + '^' + piece(baseDxRec.FBASecDx2,':',2);
292 if baseDxRec.FBASecDx3 <> '' then
293 dxString := dxString + '^' + piece(baseDxRec.FBASecDx3,':',2);
294
295 NewBillingList.Add(dxString);
296 InitializeNewDxRec(baseDxRec); //HDS00004744
297 end;
298 Result := NewBillingList;
299end;
300
301function rpcAddToPersonalDxList(UserDUZ:int64; DxCodes:TStringList):boolean;
302//input example ien^code(s) = 12345^306.70^431.22
303begin
304 Result := (sCallV('ORWDBA2 ADDPDL', [UserDUZ,DxCodes])= '1');
305end;
306
307function rpcGetPersonalDxList(UserDUZ:int64):TStringList;
308var
309tmplst: TStringList;
310begin
311 tmplst := TStringList.Create;
312 tmplst.clear;
313 tCallV(tmplst, 'ORWDBA2 GETPDL', [UserDUZ]);
314 Result := tmplst;
315end;
316
317function rpcDeleteFromPersonalDxList(UserDUZ:int64; Dest:TStringList):integer;
318begin
319 uDeleteFromPDL := StrToIntDef(sCallV('ORWDBA2 DELPDL', [UserDUZ,Dest]), 0);
320 Result := uDeleteFromPDL;
321end;
322
323// returns value used to bypass Billing Aware if needed.
324// turns off visual and functionality
325procedure rpcSetBillingAwareSwitch(encProvider:int64; pPatientDFN: string);
326begin
327// Is Provider -> Is Master Sw -> Is CIDC SW -> Is Patient Insured
328 BILLING_AWARE := FALSE;
329 // verify user is a provider
330 if (encProvider <> 0) and PersonHasKey(encProvider, 'PROVIDER') then
331 // Master switch is set "ON"
332 if (sCallV('ORWDBA1 BASTATUS', [nil]) = '1') then
333 // User is CIDC Enabled
334 if (sCallV('ORWDBA4 GETBAUSR', [encProvider]) = '1') then
335 begin
336 // Verify Patient is Insured
337 if rpcIsPatientInsured(pPatientDFN) then
338 BILLING_AWARE := TRUE;
339 end;
340 {$ifdef debug}BILLING_AWARE := TRUE;{$endif}
341end;
342
343// verify CIDC Master Switch and Provider is CIDC Enabled.
344// Patient insurance check is bypassed. (hds7564)
345function IsCIDCProvider(encProvider:int64):boolean;
346begin
347 Result := False;
348 if rpcGetBAMasterSwStatus then
349 if (encProvider <> 0) and PersonHasKey(encProvider, 'PROVIDER') then
350 Result := True;
351end;
352
353
354function rpcGetBAMasterSwStatus:boolean;
355begin
356 Result := (sCallV('ORWDBA1 BASTATUS', [nil]) = '1'); // Master switch is set "ON"
357end;
358
359
360procedure rpcSaveNurseConsultOrder(pOrderRec:TStringList);
361begin
362 rpcSaveCIDCData(pOrderRec);
363end;
364
365
366procedure rpcSaveBillingDxEntered; // if not mandatory and user enters dx.
367var
368 ordersWithDx,i: integer;
369 newBillingList: TStringList;
370 baseDxRec, tempDxRec: TBADxRecord;
371 currentOrderID, thisOrderID: string;
372 currentOrderString, thisRec: string;
373begin
374// verify Dx has been entered for orders checked for signature..
375 ordersWithDx := 0;
376 tempDxRec := TBADxRecord.Create;
377 UBAGlobals.InitializeNewDxRec(tempDxRec);
378 for i := 0 to BAOrderList.Count-1 do
379 begin
380 thisRec := BAOrderList.Strings[i];
381 thisOrderID := piece(thisRec,';',1) + ';1'; //rebuild orderID pass to M.
382 if tempDxNodeExists(thisOrderID) then
383 inc(ordersWithDx);
384 end;
385
386 // if orders have dx enteries - save billing data.
387 if ordersWithDx > 0 then
388 begin
389 newBillingList:= TStringList.Create;
390 newBillingList.Clear;
391 baseDxRec := nil;
392 baseDxRec := TBADxRecord.Create;
393 InitializeNewDxRec(baseDxRec);
394
395 try
396 for i := 0 to BAOrderList.Count-1 do
397 begin
398 currentOrderString := BAOrderList.Strings[i];
399 currentOrderID := piece(BAOrderList.Strings[i],';',1)+ ';1';
400 GetBADxListForOrder(baseDxRec, currentOrderID);
401 if baseDxRec.FBADxCode <> '' then
402 begin
403 NewBillingList.Add(currentOrderString +'^'+ baseDxRec.FBADxCode +'^'+ baseDxRec.FBASecDx1+
404 '^'+ baseDxRec.FBASecDx2+'^'+ baseDxRec.FBASecDx3);
405 end;
406 end;
407 except
408 on EListError do
409 begin
410 {$ifdef debug}ShowMessage('EListError in UBACore.rpcSaveBillingDxEntered()');{$endif}
411 raise;
412 end;
413 end;
414
415 rpcSaveCIDCData(NewBillingList);
416 if Assigned(NewBillingList) then FreeAndNil(NewBillingList);
417 end;
418end;
419
420procedure rpcGetSC4Orders;
421begin
422 RPCBrokerV.Param[0].PType := literal;
423 RPCBrokerV.Param[0].Value := Patient.DFN;
424 RPCBrokerV.RemoteProcedure := 'ORWDBA1 SCLST';
425 CallBroker;
426end;
427
428procedure rpcGetProviderPatientDaysDx(ProviderIEN: string;PatientIEN: string);
429var
430 tmplst: TStringList;
431begin
432 tmplst := TStringList.Create;
433 uDxLst := TStringList.Create;
434 tmplst.clear;
435 uDxLst.Clear;
436 tCallV(tmplst, 'ORWDBA2 GETDUDC', [ProviderIEN, PatientIEN]);
437 UBACore.UDxLst.Assign(tmplst);
438 tmplst.clear;
439end;
440
441
442function rpcGetTFHintData:TStringList;
443begin
444 tCallv(BATFHints,'ORWDBA3 HINTS', [nil]);
445 Result := BATFHints;
446end;
447
448// call made to determine if order type is billable
449// if order type NOT billable, flagged with "NA".
450function rpcNonBillableOrders(pOrderList: TStringList):TStringList;
451var x: string;
452 i: integer;
453 rList: TStringList;
454 begin
455 rList := TStringList.Create;
456 rList.Clear;
457 NonBillableOrderList.Clear;
458 // call returns boolean, orders is billable=1 or nonbillable=0 or discontinued = 0
459 tCallV(rList,'ORWDBA1 ORPKGTYP',[pOrderList]);
460 for i := 0 to rList.Count-1 do
461 begin
462 x := rList[i];
463 if rList[i] <> BILLABLE_ORDER then
464 NonBillableOrderList.Add(pOrderList[i] + U + 'NA');
465 end;
466 Result := NonBillableOrderList;
467end;
468
469
470procedure rpcBuildSCIEList(pOrderList: TList);
471var AnOrder: TOrder;
472 OrderIDList: TStringList;
473 rList: TStringList;
474 i: integer;
475 begin
476 OrderIDList := TStringList.Create;
477 rList := TStringList.Create;
478 if Assigned(OrderListSCEI) then OrderListSCEI.Clear;
479 OrderIDList.Clear;
480 rList.Clear;
481 for i := 0 to pOrderList.Count -1 do
482 begin
483 AnOrder := TOrder(pOrderList.Items[i]);
484 OrderIDList.Add(AnOrder.ID);
485 end;
486 // call returns boolean, orders is billable=1 or nonbillable=0 or discontinued = 0
487 tCallV(rList,'ORWDBA1 ORPKGTYP',[OrderIDList]);
488
489 for i := 0 to rList.Count-1 do
490 begin
491 if rList.Strings[i] = BILLABLE_ORDER then
492 OrderListSCEI.Add(OrderIDList.Strings[i]);
493 end;
494end;
495
496procedure rpcSaveCIDCData(pCIDCList: TStringList);
497var
498 CIDCList :TStringList;
499begin
500 CIDCList := TStringList.create;
501 CIDCList.Clear;
502 // insure record contain valid orderid
503 if pCIDCList.Count > 0 then
504 begin
505 CIDCList := VerifyOrderIdExists(pCIDCList);
506 if CIDCList.Count > 0 then
507 CallV('ORWDBA1 RCVORCI',[CIDCList]);
508 end;
509 if Assigned(CIDCList) then FreeAndNil(CIDCList);
510end;
511
512function rpcIsPatientInsured(pPatientDFN: string):boolean;
513begin
514 Result := (sCallV('ORWDBA7 ISWITCH',[pPatientDFN]) = '1');
515
516end;
517
518
519function OrdersHaveDx(pOrderList:TStringList):boolean;
520var
521 i: integer;
522 thisOrderID: string;
523 thisRec: string;
524 tempDxRec: TBADxRecord;
525begin
526 Result := TRUE;
527 tempDxRec := nil;
528 tempDxRec := TBADxRecord.Create;
529 UBAGlobals.InitializeNewDxRec(tempDxRec);
530
531 try
532 for i := 0 to pOrderList.Count-1 do
533 begin
534 thisRec := pOrderList.Strings[i];
535 thisOrderID := piece(thisRec,';',1) + ';1'; //rebuild orderID pass to M.
536 if not tempDxNodeExists(thisOrderID) then
537 begin
538 Result := FALSE;
539 Break;
540 end
541 else
542 begin
543 GetBADxListForOrder(tempDxRec, thisOrderID);
544 if tempDxRec.FBADxCode = '' then
545 begin
546 Result := FALSE;
547 Break;
548 end;
549 end;
550
551 end;
552 except
553 on EListError do
554 begin
555 {$ifdef debug}ShowMessage('EListError in UBACore.OrdersHaveDx()');{$endif}
556 raise;
557 end;
558 end;
559
560 if Assigned(tempDxRec) then
561 FreeAndNil(tempDxRec);
562end;
563
564
565
566
567procedure LoadUnsignedOrderRec(var thisRetVal: TBAUnsignedBillingRec;UnsignedBillingInfo:string);
568var
569 thisString : String;
570begin
571 thisString := UnsignedBillingInfo;
572 with thisRetVal do
573 begin
574 FBAOrderID := Piece(thisString,U,1) + ';1';
575 FBASTSFlags := Piece(thisString,U,2);
576 FBADxCode := (Piece(thisString,U,4)+ U + (Piece(thisString,U,3)));
577 FBASecDx1 := (Piece(thisString,U,6)+ U + (Piece(thisString,U,5)));
578 FBASecDx2 := (Piece(thisString,U,8)+ U + (Piece(thisString,U,7)));
579 FBASecDx3 := (Piece(thisString,U,10)+ U + (Piece(thisString,U,9)));
580 // if codes are absent then get rid of '^'.
581 if FBADxCode = U then FBADxCode := DXREC_INIT_FIELD_VAL;
582 if FBASecDx1 = U then FBASecDx1 := DXREC_INIT_FIELD_VAL;
583 if FBASecDx2 = U then FBASecDx2 := DXREC_INIT_FIELD_VAL;
584 if FBASecDx3 = U then FBASecDx3 := DXREC_INIT_FIELD_VAL;
585 end;
586end;
587
588procedure AttachPLTFactorsToDx(var Dest:String;ProblemRec:string);
589var
590 TFResults: string;
591 thisRec: TBAPLFactorsIN;
592begin
593 TFResults := '';
594 thisRec := TBAPLFactorsIN.Create;
595 thisRec.FBADxText := Piece(ProblemRec,'(',1);
596 thisRec.FBADxText := Piece(thisRec.FBADxText,U,2);
597 thisRec.FBADxCode := Piece(ProblemRec,U,3);
598 thisRec.FBASC := Piece(ProblemRec,U,5);
599 thisRec.FBASC_YN := Piece(ProblemRec,U,6);
600 //HDS8409
601 if StrPos(PChar(ProblemRec),'(') <> nil then
602 thisRec.FBATreatFactors := ProcessProblemTFactors(ProblemRec)
603 else
604 begin
605 thisRec.FBATreatFactors := Piece(ProblemRec,')',1);
606 thisRec.FBATreatFactors := Piece(thisRec.FBATreatFactors,'(',2);
607 end;
608 //HDS8409
609 with thisRec do
610 begin
611 if StrLen(pchar(FBATreatFactors)) > 0 then // 0 Treatment Factors exist
612 //build string containing Problem List Treatment Factors
613 TFResults := ( FBADXCode + U + FBADxText + ' (' + FBASC + '/' + FBATreatFactors + ') ' )
614 else
615 if StrLen(PChar(FBASC)) > 0 then
616 TFResults := ( FBADxCode + U + FBADxText + ' (' + FBASC + ') ' )
617 else
618 TFResults := ( FBADxCode + U + FBADxText );
619 end;
620
621 Dest := TFResults;
622end;
623
624
625// this code is to handle adding Problem List(only) TF's when selected
626procedure BALoadStsFlagsAsIs(StsFlagsIN: String);
627var
628 x: string;
629begin
630 x:= Piece(StsFlagsIN,U,2);
631 UBAGlobals.SC := Copy(x,1,1);
632 UBAGlobals.AO := Copy(x,2,1);
633 UBAGlobals.IR := Copy(x,3,1);
634 UBAGlobals.EC := Copy(x,4,1);
635 UBAGlobals.MST := Copy(x,5,1);
636 UBAGlobals.HNC := Copy(x,6,1);
637 UBAGlobals.CV := Copy(x,7,1);
638end;
639
640
641// this code is to handle adding Problem List(only) TF's when selected
642
643procedure SetTreatmentFactors(TFactors: string);
644var
645 strTFactors : string;
646 strFlagsOut: string;
647 FlagsIN : TStringList;
648 Idx: string;
649 i : integer;
650begin
651 UBAGlobals.BAFlagsOUT := TStringList.Create;
652 UBAGlobals.BAFlagsOUT.Clear;
653 FlagsIN := TStringList.Create;
654 FlagsIN.Clear;
655 FlagsIN := UBAGlobals.PLFactorsIndexes;
656
657 for i:= 0 to FlagsIN.Count-1 do
658 begin
659 BALoadStsFlagsAsIs(FlagsIN.Strings[i]);
660 IDX := Piece(FlagsIN.Strings[i],U,1);
661
662 strTFactors := TFactors;
663
664 if UBAGlobals.SC <> 'N' then
665 if StrPos(PChar(strTFactors),PChar(SERVICE_CONNECTED)) <> nil then
666 UBAGlobals.SC := 'C' ;
667
668 if UBAGlobals.SC <> 'N' then
669 if StrPos(PChar(strTFactors),PChar(NOT_SERVICE_CONNECTED)) <> nil then
670 UBAGlobals.SC := 'U';
671
672 if UBAGlobals.AO <>'N' then
673 if StrPos(PChar(strTFactors),PChar(AGENT_ORANGE)) <> nil then
674 UBAGlobals.AO := 'C';
675
676 if UBAGlobals.IR <>'N' then
677 if StrPos(PChar(strTFactors),PChar(IONIZING_RADIATION)) <> nil then
678 UBAGlobals.IR := 'C';
679
680 if UBAGlobals.EC <>'N' then
681 if StrPos(PChar(strTFactors),PChar(ENVIRONMENTAL_CONTAM)) <> nil then
682 UBAGlobals.EC := 'C';
683
684 if UBAGlobals.MST <>'N' then
685 if StrPos(PChar(strTFactors),PChar(MILITARY_SEXUAL_TRAUMA)) <> nil then
686 UBAGlobals.MST := 'C';
687
688 if UBAGlobals.CV <>'N' then
689 if StrPos(PChar(strTFactors),PChar(COMBAT_VETERAN)) <> nil then
690 UBAGlobals.CV := 'C';
691
692 if UBAGlobals.HNC <>'N' then
693 if StrPos(PChar(strTFactors),PChar(HEAD_NECK_CANCER)) <> nil then
694 UBAGlobals.HNC := 'C';
695
696 // Build Treatment Factor List to be passed to fOrdersSign form
697 strFlagsOut := (SC + AO + IR + EC + MST + HNC + CV);
698 UBAGlobals.BAFlagsOUT.Add(IDX + '^' + strFlagsOut );
699 end;
700 end;
701
702
703function StripTFactors(FactorsIN: string):string;
704var strDxCode,strDxName:string;
705begin
706 Result := '';
707 strDxCode := Piece(FactorsIN,U,2);
708 strDxName := Piece(FactorsIN,'(',1);
709 Result := (strDxName + U + strDxCode);
710end;
711
712function AddProviderPatientDaysDx(Dest: TStringList; ProviderIEN: string;PatientIEN: string) : TStringList;
713var i:integer;
714 x: string;
715 tmplst: TStringList;
716begin
717 tmplst := TStringList.Create;
718 tmplst.clear;
719 tCallV(tmplst, 'ORWDBA2 GETDUDC', [ProviderIEN, PatientIEN]);
720
721 try
722 for i := 0 to tmplst.count-1 do
723 x := tmplst.Strings[i];
724 except
725 on EListError do
726 begin
727 {$ifdef debug}ShowMessage('EListError in UBACore.AddProviderPatientDaysDx()');{$endif}
728 raise;
729 end;
730 end;
731
732 Result := tmplst;
733end;
734
735
736function OrderRequiresSCEI(pOrderID: string):boolean;
737var i:integer;
738
739begin
740 Result := False;
741
742 try
743 for i := 0 to UBAGlobals.OrderListSCEI.Count-1 do
744 begin
745 if pOrderID = UBAGlobals.OrderListSCEI.Strings[i] then
746 begin
747 Result := True;
748 Break;
749 end;
750 end;
751 except
752 on EListError do
753 begin
754 {$ifdef debug}ShowMessage('EListError in UBACore.OrderRequiresSCEI()');{$endif}
755 raise;
756 end;
757 end;
758end;
759
760procedure SaveUnsignedOrders(pOrderRec:String);
761begin
762 // save all unsigned orders, keeping freview and fordersSign in sync
763 // this change may have an impact on response time??????
764 // change from save orders with dx to save all. 06/24/04
765 // / if not clear treatment factors for order is non cidc
766 uBAGlobals.UnsignedOrders.Add(pOrderRec);
767
768end;
769
770function rpcRetrieveSelectedOrderInfo(pOrderIDList: TStringList):TStringList;
771var
772 rList : TStringList;
773 newList:TStringList;
774 i: integer;
775 x: string;
776begin
777 rList := TStringList.Create;
778 newList := TStringList.Create;
779 if Assigned(rList) then rList.Clear;
780 if Assigned(newList) then newList.Clear;
781
782 for i := 0 to pOrderIDList.Count-1 do
783 begin
784 newList.Add(Piece(pOrderIDList.Strings[i],';',1));
785 x := newlist.strings[i];
786 end;
787 if newList.Count > 0 then
788 tCallV(rList,'ORWDBA4 GETTFCI',[newList]);
789 Result := rList;
790
791
792end;
793
794procedure BuildSaveUnsignedList(pOrderList: TStringList);
795var
796 thisList: TStringList;
797 rList: TStringList;
798begin
799
800 thisList := TStringList.Create;
801 rList := TStringList.Create;
802 if Assigned(rList) then rList.Clear;
803 if Assigned(thisList)then thisList.Clear;
804 SaveBillingData(pOrderList); // save unsigned info to be displayed when recalled at later time
805end;
806
807function rpcGetUnsignedOrdersBillingData(pOrderList: TStringList):TStringList;
808var
809 i:integer;
810 newList:TStringList;
811 rList:TStringList;
812begin
813 newList := TStringList.Create;
814 rList := TStringList.Create;
815 if Assigned(newList) then newList.Clear;
816 if Assigned(rList) then rList.Clear;
817 Result := rList;
818
819 if pOrderList.Count = 0 then Exit;
820 for i := 0 to pOrderList.Count-1 do
821 begin
822 newList.Add(Piece(pOrderList.Strings[i],';',1));
823 end;
824 tCallV(rList,'ORWDBA4 GETTFCI',[newList]);
825 Result := rList;
826end;
827
828procedure CompleteUnsignedBillingInfo(pOrderList:TStringList);
829var
830i: integer;
831RecOut : TBADxRecord;
832copyList: TStringList;
833begin
834 copyList := TStringList.Create;
835 if Assigned(copyList) then copyList.Clear;
836
837 if Assigned(BAUnSignedOrders) then BAUnSignedOrders.Clear;
838
839 if not Assigned(UBAGlobals.UnsignedBillingRec) then
840 begin
841 UBAGlobals.UnSignedBillingRec := UBAGlobals.TBAUnsignedBillingRec.Create;
842 UBAGlobals.InitializeUnsignedOrderRec(UBAGlobals.UnsignedBillingRec);
843 end;
844
845 UBAGlobals.InitializeUnsignedOrderRec(UnsignedBillingRec);
846
847 try
848 for i := 0 to pOrderList.Count-1 do
849 begin
850 LoadUnsignedOrderRec(UBAGlobals.UnsignedBillingRec, pOrderList.Strings[i]);
851 if Not UBAGlobals.tempDxNodeExists(UnsignedBillingRec.FBAOrderID) then
852 begin
853 SimpleAddTempDxList(UnSignedBillingRec.FBAOrderID);
854 RecOut := TBADxRecord.Create;
855 RecOut.FExistingRecordID := UnSignedBillingRec.FBAOrderID;
856 RecOut.FBADxCode := UnsignedBillingRec.FBADxCode;
857 RecOut.FBASecDx1 := UnsignedBillingRec.FBASecDx1;
858 RecOut.FBASecDx2 := UnsignedBillingRec.FBASecDx2;
859 RecOut.FBASecDx3 := UnsignedBillingRec.FBASecDx3;
860 RecOut.FTreatmentFactors := UnSignedBillingRec.FBASTSFlags;
861 PutBADxListForOrder(RecOut, RecOut.FExistingRecordID);
862 UBAGlobals.BAUnSignedOrders.Add(UnSignedBillingRec.FBAOrderID + '^' + UnSignedBillingRec.FBASTSFlags);
863 end
864 else
865 begin
866 RecOut := TBADxRecord.Create;
867 if tempDxNodeExists(UnSignedBillingRec.FBAOrderID) then
868 begin
869 GetBADxListForOrder(RecOut, UnSignedBillingRec.FBAOrderID); //load data from source
870 copyList.Add(UnSignedBillingRec.FBAOrderID + '^' + UnSignedBillingRec.FBASTSFlags);
871 BuildSaveUnsignedList(copyList);
872 end;
873 end;
874 end;
875 except
876 on EListError do
877 begin
878 {$ifdef debug}ShowMessage('EListError in UBACore.CompleteUnsignedBillingInfo()');{$endif}
879 raise;
880 end;
881 end;
882end;
883
884function GetUnsignedOrderFlags(pOrderID: string; pFlagList: TStringList):string;
885var
886 i: integer;
887begin
888 Result := '';
889 try
890 for i := 0 to pFlagList.Count-1 do
891 begin
892 if pOrderID = Piece(pFlagList.Strings[i],U,1) then
893 begin
894 Result := Piece(pFlagList.Strings[i],U,2); // STSFlags
895 Break;
896 end;
897 end;
898 except
899 on EListError do
900 begin
901 {$ifdef debug}ShowMessage('EListError in UBACore.GetUnsignedOrderFlags()');{$endif}
902 raise;
903 end;
904 end;
905
906end;
907
908// BuildTFHintRec is meant to run once, first user of the session
909// contains the information to be displayed while mouse-over in fOrdersSign and fReview.
910procedure BuildTFHintRec;
911var
912hintList :TStringList;
913i: integer;
914x: string;
915begin
916 hintList := TStringList.Create;
917 if Assigned(hintList) then hintList.Clear;
918 hintList := rpcGetTFHintData;
919 if hintList.Count > 0 then UBAGlobals.BAFactorsRec.FBAFactorActive := TRUE;
920
921 try
922 for i := 0 to hintList.Count -1 do
923 begin
924 x := hintList.Strings[i];
925 if piece(x,U,1) = SERVICE_CONNECTED then
926 begin
927 if piece(x,U,2) = '1' then
928 UBAGlobals.BAFactorsRec.FBAFactorSC := Piece(x,U,3)
929 else
930 UBAGlobals.BAFactorsRec.FBAFactorSC := ( UBAGlobals.BAFactorsRec.FBAFactorSC + CRLF + Piece(x,U,3) );
931 end
932 else
933 if piece(x,U,1) = AGENT_ORANGE then
934 begin
935 if piece(x,U,2) = '1' then
936 UBAGlobals.BAFactorsRec.FBAFactorAO := Piece(x,U,3)
937 else
938 UBAGlobals.BAFactorsRec.FBAFactorAO := (UBAGlobals.BAFactorsRec.FBAFactorAO + CRLF + Piece(x,U,3) );
939 end
940 else
941 if piece(x,U,1) = IONIZING_RADIATION then
942 begin
943 if piece(x,U,2) = '1' then
944 UBAGlobals.BAFactorsRec.FBAFactorIR := Piece(x,U,3)
945 else
946 UBAGlobals.BAFactorsRec.FBAFactorIR := (UBAGlobals.BAFactorsRec.FBAFactorIR + CRLF + Piece(x,U,3) );
947 end
948 else
949 if piece(x,U,1) = ENVIRONMENTAL_CONTAM then
950 begin
951 if piece(x,U,2) = '1' then
952 UBAGlobals.BAFactorsRec.FBAFactorEC := Piece(x,U,3)
953 else
954 UBAGlobals.BAFactorsRec.FBAFactorEC := (UBAGlobals.BAFactorsRec.FBAFactorEC + CRLF + Piece(x,U,3) );
955 end
956 else
957 if piece(x,U,1) = HEAD_NECK_CANCER then
958 begin
959 if piece(x,U,2) = '1' then
960 UBAGlobals.BAFactorsRec.FBAFactorHNC := Piece(x,U,3)
961 else
962 UBAGlobals.BAFactorsRec.FBAFactorHNC := (UBAGlobals.BAFactorsRec.FBAFactorHNC + CRLF + Piece(x,U,3) );
963 end
964 else
965 if piece(x,U,1) = MILITARY_SEXUAL_TRAUMA then
966 begin
967 if piece(x,U,2) = '1' then
968 UBAGlobals.BAFactorsRec.FBAFactorMST := Piece(x,U,3)
969 else
970 UBAGlobals.BAFactorsRec.FBAFactorMST := (UBAGlobals.BAFactorsRec.FBAFactorMST + CRLF + Piece(x,U,3) );
971 end
972 else
973 if piece(x,U,1) = COMBAT_VETERAN then
974 begin
975 if piece(x,U,2) = '1' then
976 UBAGlobals.BAFactorsRec.FBAFactorCV := Piece(x,U,3)
977 else
978 UBAGlobals.BAFactorsRec.FBAFactorCV := (UBAGlobals.BAFactorsRec.FBAFactorCV + CRLF + Piece(x,U,3) );
979 end;
980 end;
981 except
982 on EListError do
983 begin
984 {$ifdef debug}ShowMessage('EListError in UBACore.BuileTFHintRec()');{$endif}
985 raise;
986 end;
987 end;
988end;
989
990
991function IsAllOrdersNA(pOrderList:TStringList):boolean;
992var
993 i:integer;
994 rList: TStringList;
995begin
996 rList := TStringList.Create;
997 if Assigned(rList) then rList.Clear;
998 Result := True;// disables dx button
999
1000 // call returns boolean, orders is billable=1 or nonbillable=0 or discontinued = 0
1001 tCallV(rList,'ORWDBA1 ORPKGTYP',[pOrderList]);
1002
1003 for i := 0 to rList.Count-1 do
1004 begin
1005 if rList.Strings[i] = BILLABLE_ORDER then
1006 begin
1007 Result := False;
1008 Break;
1009 end;
1010 end;
1011end;
1012
1013function PrepOrderID(pOrderID:String): String;
1014var
1015 newOrderID: String;
1016begin
1017 newOrderID := '';
1018 if pos(';',pOrderID) > 0 then
1019 newOrderID := Piece(pOrderID,';',1)
1020 else
1021 newOrderID := pOrderID ;
1022
1023 Result := newOrderID;
1024end;
1025
1026procedure ClearSelectedOrderDiagnoses(pOrderIDList: TStringList);
1027var
1028 RecOut: TBADXRecord;
1029 i: integer;
1030begin
1031 try
1032 for i := 0 to pOrderIDList.Count-1 do
1033 begin
1034 if UBAGlobals.tempDxNodeExists(pOrderIDList.Strings[i]) then
1035 begin
1036 RecOut := TBADxRecord.Create;
1037 GetBADxListForOrder(RecOut, pOrderIDList.Strings[i]);
1038 RecOut.FOrderID := RecOut.FOrderID;
1039 RecOut.FBADxCode := DXREC_INIT_FIELD_VAL;
1040 RecOut.FBASecDx1 := DXREC_INIT_FIELD_VAL;
1041 RecOut.FBASecDx2 := DXREC_INIT_FIELD_VAL;
1042 RecOut.FBASecDx3 := DXREC_INIT_FIELD_VAL;
1043 PutBADxListForOrder(RecOut, pOrderIDList.Strings[i]);
1044 frmReview.lstReview.Refresh;
1045 end;
1046 end;
1047 except
1048 on EListError do
1049 begin
1050 {$ifdef debug}ShowMessage('EListError in UBACore.ClearSelectedORdersDiagnoses()');{$endif}
1051 raise;
1052 end;
1053 end;
1054end;
1055
1056procedure LoadConsultOrderRec(var thisRetVal: TBAConsultOrderRec; pOrderID: String; pDxList: TStringList);
1057var
1058 thisString, thisFlags:String;
1059 dx1,dx2,dx3,dx4: string;
1060 i: integer;
1061begin
1062 thisFlags := '';
1063 dx1 := '';
1064 dx2 := '';
1065 dx3 := '';
1066 dx4 := '';
1067 UBAGlobals.BAConsultDxList.Sort;
1068
1069 try
1070 for i := 0 to UBAGlobals.BAConsultDxList.Count -1 do
1071 begin
1072 thisString := UBAGlobals.BAConsultDxList[i];
1073
1074 if i = 0 then
1075 begin
1076 if pos( '(', thisString) > 0 then
1077 begin
1078 thisFlags := Piece(thisString,'(',2);
1079 thisFlags := Piece(thisFlags,')',1);
1080 UBAGlobals.BAConsultPLFlags.Add(pOrderID + U + thisFlags);
1081 dx1 := Piece(thisString,U,2);
1082 dx1 := Piece(dx1,'(',1) + U + Piece(thisString,':',2);
1083 end
1084 else
1085 begin
1086 dx1 := Piece(thisString,U,2);
1087 dx1 := Piece(dx1,':',1)+ U + Piece(thisString,':',2);
1088 end
1089 end
1090 else
1091 if i = 1 then
1092 begin
1093 if pos( '(', thisString) > 0 then
1094 begin
1095 dx2 := Piece(thisString,U,2);
1096 dx2 := Piece(dx2,'(',1)+ U + Piece(thisString,':',2);
1097 end
1098 else
1099 begin
1100 dx2 := Piece(thisString,U,2);
1101 dx2 := Piece(dx2,':',1)+ U + Piece(thisString,':',2);
1102 end
1103 end
1104 else
1105 if i = 2 then
1106 begin
1107 if pos( '(', thisString) > 0 then
1108 begin
1109 dx3 := Piece(thisString,U,2);
1110 dx3 := Piece(dx3,'(',1)+ U + Piece(thisString,':',2);
1111 end
1112 else
1113 begin
1114 dx3 := Piece(thisString,U,2);
1115 dx3 := Piece(dx3,':',1)+ U + Piece(thisString,':',2);
1116 end
1117 end
1118 else
1119 if i = 3 then
1120 begin
1121 if pos( '(', thisString) > 0 then
1122 begin
1123 dx4 := Piece(thisString,U,2);
1124 dx4 := Piece(dx4,'(',1)+ U + Piece(thisString,':',2);
1125 end
1126 else
1127 begin
1128 dx4 := Piece(thisString,U,2);
1129 dx4 := Piece(dx4,':',1)+ U + Piece(thisString,':',2);
1130 end;
1131 end;
1132 end;
1133 except
1134 on EListError do
1135 begin
1136 {$ifdef debug}ShowMessage('EListError in UBACore.LoadConsultOrderRec()');{$endif}
1137 raise;
1138 end;
1139 end;
1140
1141 with thisRetVal do
1142 begin
1143 FBAOrderID := pOrderID;
1144 FBATreatmentFactors:= thisFlags;
1145 FBADxCode := dx1;
1146 FBASecDx1 := dx2;
1147 FBASecDx2 := dx3;
1148 FBASecDx3 := dx4;
1149 end;
1150end;
1151
1152procedure LoadTFactorsInRec(var thisRetVal: TBATreatmentFactorsInRec; pOrderID:string; pEligible: string; pTFactors:string);
1153begin
1154 with thisRetVal do
1155 begin
1156 FBAOrderID := pOrderID;
1157 FBAEligible := pEligible;
1158 FBATFactors := pTFactors;
1159 end;
1160end;
1161
1162procedure CompleteConsultOrderRec(pOrderID: string; pDxList: TStringList);
1163var
1164 RecOut : TBADxRecord;
1165 TfFlags,dxRec: string;
1166 orderList : TStringList;
1167 tmpOrderList: TStringList;
1168begin
1169 orderList := TStringList.Create;
1170 tmpOrderList := TStringList.Create;
1171 orderList.Clear;
1172 tmpOrderList.Clear;
1173 if not Assigned(uBAGlobals.ConsultOrderRec)then
1174 begin
1175 UBAGlobals.ConsultOrderRec := UBAGlobals.TBAConsultOrderRec.Create;
1176 InitializeConsultOrderRec(UBAGlobals.ConsultOrderRec);
1177 end
1178 else
1179 InitializeConsultOrderRec(UBAGlobals.ConsultOrderRec);
1180 // call rpc to load list with boolean values based on orders package type.
1181 UBAGlobals.NonBillableOrderList.Clear;
1182 tmpOrderList.Add(UBAGLobals.BAOrderID);
1183 rpcNonBillableOrders(tmpOrderList);
1184 if IsOrderBillable(uBAGlobals.BAOrderID) then
1185 begin
1186 if not UBAGlobals.tempDxNodeExists(uBAGlobals.BAOrderID) then
1187 begin
1188 LoadConsultOrderRec(UBAGlobals.ConsultOrderRec,UBAGlobals.BAOrderID,uBAGlobals.BAConsultDxList);
1189 if NOT UBAGlobals.tempDxNodeExists(pOrderID) then
1190 SimpleAddTempDxList(pOrderID);
1191 RecOut := TBADxRecord.Create;
1192 RecOut.FExistingRecordID := pOrderID;
1193 RecOut.FBADxCode := ConsultOrderRec.FBADxCode;
1194 RecOut.FBASecDx1 := ConsultOrderRec.FBASecDx1;
1195 RecOut.FBASecDx2 := ConsultOrderRec.FBASecDx2;
1196 RecOut.FBASecDx3 := ConsultOrderRec.FBASecDx3;
1197 RecOut.FTreatmentFactors := ConsultOrderRec.FBATreatmentFactors;
1198 PutBADxListForOrder(RecOut, RecOut.FExistingRecordID);
1199// HDS00003380
1200 if IsUserNurseProvider(User.DUZ) then
1201 begin
1202 dxRec := BuildConsultDxRec(ConsultOrderRec);
1203 orderList.Add(RecOut.FExistingRecordID);
1204 // TfFlags := Piece(GetPatientTFactors(orderList),U,2);
1205 TfFlags := GetPatientTFactors(orderList);
1206 TfFlags := ConvertPIMTreatmentFactors(TfFlags);
1207 orderList.Clear;
1208 // if strLen(PChar(dxRec)) > 0 then
1209 // orderList.Add(RecOut.FExistingRecordID +TfFlags + '^'+ BuildConsultDxRec(ConsultOrderRec) )
1210 // else
1211 orderList.Add(RecOut.FExistingRecordID +TfFlags);
1212 SaveBillingData(OrderList); // save unsigned info to be displayed when re
1213 end;
1214 end;
1215 end;
1216end;
1217
1218function GetConsultFlags(pOrderID:String; pFlagList:TStringList;FlagsAsIs:string):string;
1219var
1220 i: integer; //add code to match order id.....
1221begin
1222 Result := '';
1223 for i := 0 to pFlagList.Count -1 do
1224 begin
1225 if pOrderID = Piece(pFlagList.Strings[i],U,1) then
1226 begin
1227 Result := SetConsultFlags( Piece(pFlagList.Strings[i],U,2), FlagsAsIs);
1228 break;
1229 end;
1230 end;
1231
1232end;
1233
1234function SetConsultFlags(pPLFactors: string; pFlagsAsIs:string):string; // return updated flags.
1235var
1236 strFlagsAsIs: string;
1237 strTFactors: string;
1238 strFlagsOut,x: string;
1239
1240begin
1241 strFlagsAsIs := pFlagsAsIs; // flags from pims
1242 strTFactors := pPLFactors; // value selected from problem list
1243 strFlagsOut := ''; // flags updated with selected values from problem list
1244 x := strFlagsAsIs;
1245 Result := '';
1246
1247 UBAGlobals.SC := Copy(x,1,1);
1248 UBAGlobals.AO := Copy(x,2,1);
1249 UBAGlobals.IR := Copy(x,3,1);
1250 UBAGlobals.EC := Copy(x,4,1);
1251 UBAGlobals.MST := Copy(x,5,1);
1252 UBAGlobals.HNC := Copy(x,6,1);
1253 UBAGlobals.CV := Copy(x,7,1); // load factors to global vars;
1254
1255 if UBAGlobals.SC <> 'N' then
1256 if StrPos(PChar(strTFactors),PChar(SERVICE_CONNECTED)) <> nil then
1257 UBAGlobals.SC := 'C' ;
1258
1259 if UBAGlobals.SC <> 'N' then
1260 if StrPos(PChar(strTFactors),PChar(NOT_SERVICE_CONNECTED)) <> nil then
1261 UBAGlobals.SC := 'U';
1262
1263 if UBAGlobals.AO <>'N' then
1264 if StrPos(PChar(strTFactors),PChar(AGENT_ORANGE)) <> nil then
1265 UBAGlobals.AO := 'C';
1266
1267 if UBAGlobals.IR <>'N' then
1268 if StrPos(PChar(strTFactors),PChar(IONIZING_RADIATION)) <> nil then
1269 UBAGlobals.IR := 'C';
1270
1271 if UBAGlobals.EC <>'N' then
1272 if StrPos(PChar(strTFactors),PChar(ENVIRONMENTAL_CONTAM)) <> nil then
1273 UBAGlobals.EC := 'C';
1274
1275 if UBAGlobals.MST <>'N' then
1276 if StrPos(PChar(strTFactors),PChar(MILITARY_SEXUAL_TRAUMA)) <> nil then
1277 UBAGlobals.MST := 'C';
1278
1279 if UBAGlobals.HNC <> 'N' then
1280 if StrPos(PChar(strTFactors),PChar(HEAD_NECK_CANCER)) <> nil then
1281 UBAGlobals.HNC := 'C';
1282
1283 if UBAGlobals.CV <>'N' then
1284 if StrPos(PChar(strTFactors),PChar(COMBAT_VETERAN)) <> nil then
1285 UBAGlobals.CV := 'C';
1286
1287 strFlagsOut := (UBAGlobals.SC + UBAGlobals.AO + UBAGlobals.IR +
1288 UBAGlobals.EC + UBAGlobals.MST + UBAGlobals.HNC +
1289 UBAGlobals.CV);
1290 Result := strFlagsOut;
1291end;
1292
1293procedure GetBAStatus(pProvider:int64; pPatientDFN: string);
1294begin
1295 // sets global switch, based in value returned from server.
1296 // True -> Billing Aware Switch ON. else OFF
1297
1298 UBACore.rpcSetBillingAwareSwitch(pProvider,pPatientDFN);
1299
1300 if Assigned(UBAGlobals.BAPCEDiagList) then UBAGlobals.BAPCEDiagList.Clear;
1301 frmFrame.SetBADxList;
1302 if not UBAGlobals.BAFactorsRec.FBAFactorActive then
1303 UBACore.BuildTFHintRec;
1304end;
1305
1306function IsICD9CodeActive(ACode: string; LexApp: string; ADate: TFMDateTime = 0): boolean;
1307var
1308 inactiveChar : string;
1309begin
1310 inactiveChar := '#';
1311 if StrPos(PChar(ACode),PChar(inactiveChar) ) <> nil then
1312 ACode := Piece(ACode,'#',1); // remove the '#' added for inactive code.
1313 Result := (sCallV('ORWPCE ACTIVE CODE',[ACode, LexApp, ADate]) = '1');
1314end;
1315
1316function BuildConsultDxRec(ConsultRec: TBAConsultOrderRec): string;
1317var
1318newString: string;
1319begin
1320 if strLen(PChar(ConsultRec.FBADxCode)) > 0 then
1321 newString := Piece(ConsultRec.FBADxCode,U,2)
1322 else
1323 if strLen(PChar(ConsultRec.FBASecDx1)) > 0 then
1324 newString := newString + '^' + Piece(ConsultRec.FBASecDx1,U,2)
1325 else
1326 if strLen(PChar(ConsultRec.FBASecDx2)) > 0 then
1327 newString := newString + '^' + Piece(ConsultRec.FBASecDx2,U,2)
1328 else
1329 if strLen(PChar(ConsultRec.FBASecDx3)) > 0 then
1330 newString := newString + '^' + Piece(ConsultRec.FBASecDx3,U,2);
1331 Result := newString;
1332end;
1333
1334function ConvertPIMTreatmentFactors(pTFactors:string):string;
1335var
1336 strSC,strAO, strIR: string;
1337 strEC, strMST, strHNC, strCV: string;
1338
1339begin
1340 Result := '';
1341 if StrPos(PChar(pTFactors),PChar(SERVICE_CONNECTED)) <> nil then
1342 strSC := '?'
1343 else
1344 strSC := 'N';
1345
1346 if StrPos(PChar(pTFactors),PChar(AGENT_ORANGE)) <> nil then
1347 strAO := '?'
1348 else
1349 strAO := 'N';
1350
1351 if StrPos(PChar(pTFactors),PChar(IONIZING_RADIATION)) <> nil then
1352 strIR := '?'
1353 else
1354 strIR := 'N';
1355
1356 if StrPos(PChar(pTFactors),PChar(ENVIRONMENTAL_CONTAM)) <> nil then
1357 strEC := '?'
1358 else
1359 strEC := 'N';
1360
1361 if StrPos(PChar(pTFactors),PChar(MILITARY_SEXUAL_TRAUMA)) <> nil then
1362 strMST := '?'
1363 else
1364 strMST := 'N';
1365
1366 if StrPos(PChar(pTFactors),PChar(HEAD_NECK_CANCER)) <> nil then
1367 strHNC := '?'
1368 else
1369 strHNC := 'N';
1370
1371 if StrPos(PChar(pTFactors),PChar(COMBAT_VETERAN)) <> nil then
1372 strCV := '?'
1373 else
1374 strCV := 'N';
1375
1376 Result := (strSC + strAO + strIR + strEC + strMST + strHNC + strCV);
1377end;
1378
1379
1380// Delete dc'd orders from BACopiedOrderList to keep things in sync.
1381procedure DeleteDCOrdersFromCopiedList(pOrderID:string);
1382var i:integer;
1383 holdList: TStringList;
1384 x: string;
1385begin
1386 holdList := TStringList.Create;
1387 holdList.Clear;
1388 holdList.Assign(UBAGlobals.BACopiedOrderFlags);
1389 UBAGlobals.BACopiedOrderFlags.Clear;
1390 for i := 0 to holdList.Count-1 do
1391 begin
1392 x := Piece(holdList.Strings[i],';',1);
1393 if pOrderID = Piece(holdList.Strings[i],';',1) then
1394 continue
1395 else
1396 UBAGlobals.BACopiedOrderFlags.Add(holdList.Strings[i]);
1397 end;
1398end;
1399
1400procedure UpdateBAConsultOrderList(pDcOrders: TStringList);
1401var
1402 x: string;
1403 var i,j: integer;
1404 holdList : TStringList;
1405begin
1406 // remove order enteries from the dx list that are being discontinued.
1407 for i := 0 to pDcOrders.Count -1 do
1408 begin
1409 UBAGlobals.RemoveOrderFromDxList(pDcOrders.Strings[i]);
1410 end;
1411 if UBAGlobals.BAConsultPLFlags.Count > 0 then
1412 begin
1413 holdList := TStringList.Create;
1414 holdList.Clear;
1415 holdList.Assign(UBAGlobals.BAConsultPLFlags);
1416 UBAGlobals.BAConsultPLFlags.Clear;
1417 for i := 0 to holdList.Count-1 do
1418 begin
1419 x := holdList.Strings[i];
1420 for j := 0 to pDcOrders.Count-1 do
1421 begin
1422 if x = pDcOrders.Strings[j] then
1423 continue
1424 else
1425 UBAGlobals.BAConsultPLFlags.Add(x);
1426 end;
1427 end;
1428 end;
1429end;
1430
1431// loop thru CIDC records remove records with invalid orderid
1432function VerifyOrderIdExists(pOrderList: TStringList): TStringList;
1433var
1434 goodList: TStringList;
1435 tOrderID: integer;
1436 i: integer;
1437begin
1438 goodList := TStringList.Create;
1439 goodList.clear;
1440
1441 if pOrderList.Count > 0 then
1442 begin
1443 for i := 0 to pOrderList.Count-1 do
1444 begin
1445 tOrderID := StrToIntDef(Piece(pOrderList.Strings[i],';',1), 0);
1446 if tOrderID > 0 then
1447 goodList.add(pOrderList.Strings[i]);
1448 end;
1449 end;
1450 result := goodList;
1451end;
1452
1453// parse string return Treatment Factors when text inlcudes multiple "(())"
1454//HDS8409
1455function ProcessProblemTFactors(pText:String):String;
1456var AText1,x: string;
1457 i,j: integer;
1458begin
1459 if StrPos(PChar(pText),'(') = nil then exit;
1460 AText1 := Piece(pText,U,2);
1461 i := 1;
1462 j := 0;
1463 while j = 0 do
1464 begin
1465 x := Piece(AText1,'(',i);
1466 if Length(x) > 0 then
1467 inc(i)
1468 else
1469 begin
1470 x := Piece(AText1,'(',i-1);
1471 x := Piece(x,')',1);
1472 j := 1;
1473 Result := x;
1474 end;
1475 end;
1476end;
1477
1478end.
1479
1480
1481
Note: See TracBrowser for help on using the repository browser.