source: cprs/trunk/CPRS-Chart/BA/UBACore.pas@ 458

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

Initial Upload of Official WV CPRS 1.0.26.76

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