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

Last change on this file since 1535 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27

File size: 48.6 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 FastAssign(holdOrderList, BAOrderList); //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 FastAssign(updatedBAOrderList, BAOrderList);
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 FastAssign(pList, updatedList);
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}Show508Message('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 // OR Switch = 2 ask questions for all patients.
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}Show508Message('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// ****** RPC Logic returning SC/TF codes for COPAY ********
423// if (CIDC is ON) and (PatientInsured is True) then
424// return SC/TF for OutPatient Meds, Labs, Prosthetics, Imaging.
425// else
426// return SC/TF for Outpatient Meds only.
427 RPCBrokerV.Param[0].PType := literal;
428 RPCBrokerV.Param[0].Value := Patient.DFN;
429 RPCBrokerV.RemoteProcedure := 'ORWDBA1 SCLST';
430 CallBroker;
431end;
432
433procedure rpcGetProviderPatientDaysDx(ProviderIEN: string;PatientIEN: string);
434var
435 tmplst: TStringList;
436begin
437 tmplst := TStringList.Create;
438 uDxLst := TStringList.Create;
439 tmplst.clear;
440 uDxLst.Clear;
441 tCallV(tmplst, 'ORWDBA2 GETDUDC', [ProviderIEN, PatientIEN]);
442 FastAssign(tmplst, UBACore.UDxLst);
443 tmplst.clear;
444end;
445
446
447function rpcGetTFHintData:TStringList;
448begin
449 tCallv(BATFHints,'ORWDBA3 HINTS', [nil]);
450 Result := BATFHints;
451end;
452
453// call made to determine if order type is billable
454// if order type NOT billable, flagged with "NA".
455function rpcNonBillableOrders(pOrderList: TStringList):TStringList;
456var x: string;
457 i: integer;
458 rList: TStringList;
459 begin
460 rList := TStringList.Create;
461 rList.Clear;
462 NonBillableOrderList.Clear;
463 // call returns boolean, orders is billable=1 or nonbillable=0 or discontinued = 0
464 tCallV(rList,'ORWDBA1 ORPKGTYP',[pOrderList]);
465 for i := 0 to rList.Count-1 do
466 begin
467 x := rList[i];
468 if rList[i] <> BILLABLE_ORDER then
469 NonBillableOrderList.Add(pOrderList[i] + U + 'NA');
470 end;
471 Result := NonBillableOrderList;
472end;
473
474
475procedure rpcBuildSCIEList(pOrderList: TList);
476var AnOrder: TOrder;
477 OrderIDList: TStringList;
478 rList: TStringList;
479 i: integer;
480 begin
481 OrderIDList := TStringList.Create;
482 rList := TStringList.Create;
483 if Assigned(OrderListSCEI) then OrderListSCEI.Clear;
484 OrderIDList.Clear;
485 rList.Clear;
486 for i := 0 to pOrderList.Count -1 do
487 begin
488 AnOrder := TOrder(pOrderList.Items[i]);
489 OrderIDList.Add(AnOrder.ID);
490 end;
491 // call returns boolean, orders is billable=1 or nonbillable=0 or discontinued = 0
492 tCallV(rList,'ORWDBA1 ORPKGTYP',[OrderIDList]);
493
494 for i := 0 to rList.Count-1 do
495 begin
496 if rList.Strings[i] = BILLABLE_ORDER then
497 OrderListSCEI.Add(OrderIDList.Strings[i]);
498 end;
499end;
500
501procedure rpcSaveCIDCData(pCIDCList: TStringList);
502var
503 CIDCList :TStringList;
504begin
505 CIDCList := TStringList.create;
506 CIDCList.Clear;
507 // insure record contain valid orderid
508 if pCIDCList.Count > 0 then
509 begin
510 CIDCList := VerifyOrderIdExists(pCIDCList);
511 if CIDCList.Count > 0 then
512 CallV('ORWDBA1 RCVORCI',[CIDCList]);
513 end;
514 if Assigned(CIDCList) then FreeAndNil(CIDCList);
515end;
516
517function rpcIsPatientInsured(pPatientDFN: string):boolean;
518begin
519 Result := (sCallV('ORWDBA7 ISWITCH',[pPatientDFN]) > '0');
520
521end;
522
523
524function OrdersHaveDx(pOrderList:TStringList):boolean;
525var
526 i: integer;
527 thisOrderID: string;
528 thisRec: string;
529 tempDxRec: TBADxRecord;
530begin
531 Result := TRUE;
532 tempDxRec := nil;
533 tempDxRec := TBADxRecord.Create;
534 UBAGlobals.InitializeNewDxRec(tempDxRec);
535
536 try
537 for i := 0 to pOrderList.Count-1 do
538 begin
539 thisRec := pOrderList.Strings[i];
540 thisOrderID := piece(thisRec,';',1) + ';1'; //rebuild orderID pass to M.
541 if not tempDxNodeExists(thisOrderID) then
542 begin
543 Result := FALSE;
544 Break;
545 end
546 else
547 begin
548 GetBADxListForOrder(tempDxRec, thisOrderID);
549 if tempDxRec.FBADxCode = '' then
550 begin
551 Result := FALSE;
552 Break;
553 end;
554 end;
555
556 end;
557 except
558 on EListError do
559 begin
560 {$ifdef debug}Show508Message('EListError in UBACore.OrdersHaveDx()');{$endif}
561 raise;
562 end;
563 end;
564
565 if Assigned(tempDxRec) then
566 FreeAndNil(tempDxRec);
567end;
568
569
570
571
572procedure LoadUnsignedOrderRec(var thisRetVal: TBAUnsignedBillingRec;UnsignedBillingInfo:string);
573var
574 thisString : String;
575begin
576 thisString := UnsignedBillingInfo;
577 with thisRetVal do
578 begin
579 FBAOrderID := Piece(thisString,U,1) + ';1';
580 FBASTSFlags := Piece(thisString,U,2);
581 FBADxCode := (Piece(thisString,U,4)+ U + (Piece(thisString,U,3)));
582 FBASecDx1 := (Piece(thisString,U,6)+ U + (Piece(thisString,U,5)));
583 FBASecDx2 := (Piece(thisString,U,8)+ U + (Piece(thisString,U,7)));
584 FBASecDx3 := (Piece(thisString,U,10)+ U + (Piece(thisString,U,9)));
585 // if codes are absent then get rid of '^'.
586 if FBADxCode = U then FBADxCode := DXREC_INIT_FIELD_VAL;
587 if FBASecDx1 = U then FBASecDx1 := DXREC_INIT_FIELD_VAL;
588 if FBASecDx2 = U then FBASecDx2 := DXREC_INIT_FIELD_VAL;
589 if FBASecDx3 = U then FBASecDx3 := DXREC_INIT_FIELD_VAL;
590 end;
591end;
592
593procedure AttachPLTFactorsToDx(var Dest:String;ProblemRec:string);
594var
595 TFResults: string;
596 thisRec: TBAPLFactorsIN;
597begin
598 TFResults := '';
599 thisRec := TBAPLFactorsIN.Create;
600 thisRec.FBADxText := Piece(ProblemRec,'(',1);
601 thisRec.FBADxText := Piece(thisRec.FBADxText,U,2);
602 thisRec.FBADxCode := Piece(ProblemRec,U,3);
603 thisRec.FBASC := Piece(ProblemRec,U,5);
604 thisRec.FBASC_YN := Piece(ProblemRec,U,6);
605 //HDS8409
606 if StrPos(PChar(ProblemRec),'(') <> nil then
607 thisRec.FBATreatFactors := ProcessProblemTFactors(ProblemRec)
608 else
609 begin
610 thisRec.FBATreatFactors := Piece(ProblemRec,')',1);
611 thisRec.FBATreatFactors := Piece(thisRec.FBATreatFactors,'(',2);
612 end;
613 //HDS8409
614 with thisRec do
615 begin
616 if StrLen(pchar(FBATreatFactors)) > 0 then // 0 Treatment Factors exist
617 //build string containing Problem List Treatment Factors
618 TFResults := ( FBADXCode + U + FBADxText + ' (' + FBASC + '/' + FBATreatFactors + ') ' )
619 else
620 if StrLen(PChar(FBASC)) > 0 then
621 TFResults := ( FBADxCode + U + FBADxText + ' (' + FBASC + ') ' )
622 else
623 TFResults := ( FBADxCode + U + FBADxText );
624 end;
625
626 Dest := TFResults;
627end;
628
629
630// this code is to handle adding Problem List(only) TF's when selected
631procedure BALoadStsFlagsAsIs(StsFlagsIN: String);
632var
633 x: string;
634begin
635 x:= Piece(StsFlagsIN,U,2);
636 UBAGlobals.SC := Copy(x,1,1);
637 UBAGlobals.AO := Copy(x,2,1);
638 UBAGlobals.IR := Copy(x,3,1);
639 UBAGlobals.EC := Copy(x,4,1);
640 UBAGlobals.MST := Copy(x,5,1);
641 UBAGlobals.HNC := Copy(x,6,1);
642 UBAGlobals.CV := Copy(x,7,1);
643 UBAGlobals.SHD := Copy(x,8,1);
644end;
645
646
647// this code is to handle adding Problem List(only) TF's when selected
648
649procedure SetTreatmentFactors(TFactors: string);
650var
651 strTFactors : string;
652 strFlagsOut: string;
653 FlagsIN : TStringList;
654 Idx: string;
655 i : integer;
656begin
657 UBAGlobals.BAFlagsOUT := TStringList.Create;
658 UBAGlobals.BAFlagsOUT.Clear;
659 FlagsIN := TStringList.Create;
660 FlagsIN.Clear;
661 FlagsIN := UBAGlobals.PLFactorsIndexes;
662
663 for i:= 0 to FlagsIN.Count-1 do
664 begin
665 BALoadStsFlagsAsIs(FlagsIN.Strings[i]);
666 IDX := Piece(FlagsIN.Strings[i],U,1);
667
668 strTFactors := TFactors;
669
670 if UBAGlobals.SC <> 'N' then
671 if StrPos(PChar(strTFactors),PChar(SERVICE_CONNECTED)) <> nil then
672 UBAGlobals.SC := 'C' ;
673
674 if UBAGlobals.SC <> 'N' then
675 if StrPos(PChar(strTFactors),PChar(NOT_SERVICE_CONNECTED)) <> nil then
676 UBAGlobals.SC := 'U';
677
678 if UBAGlobals.AO <>'N' then
679 if StrPos(PChar(strTFactors),PChar(AGENT_ORANGE)) <> nil then
680 UBAGlobals.AO := 'C';
681
682 if UBAGlobals.IR <>'N' then
683 if StrPos(PChar(strTFactors),PChar(IONIZING_RADIATION)) <> nil then
684 UBAGlobals.IR := 'C';
685
686 if UBAGlobals.EC <>'N' then
687 if StrPos(PChar(strTFactors),PChar(ENVIRONMENTAL_CONTAM)) <> nil then
688 UBAGlobals.EC := 'C';
689
690 if UBAGlobals.MST <>'N' then
691 if StrPos(PChar(strTFactors),PChar(MILITARY_SEXUAL_TRAUMA)) <> nil then
692 UBAGlobals.MST := 'C';
693
694 if UBAGlobals.CV <>'N' then
695 if StrPos(PChar(strTFactors),PChar(COMBAT_VETERAN)) <> nil then
696 UBAGlobals.CV := 'C';
697
698 if UBAGlobals.HNC <>'N' then
699 if StrPos(PChar(strTFactors),PChar(HEAD_NECK_CANCER)) <> nil then
700 UBAGlobals.HNC := 'C';
701
702 if UBAGlobals.SHD <> 'N' then
703 if StrPos(PChar(strTFactors),PChar(SHIPBOARD_HAZARD_DEFENSE)) <> nil then
704 UBAGlobals.SHD := 'C';
705
706 // Build Treatment Factor List to be passed to fOrdersSign form
707 strFlagsOut := (SC + AO + IR + EC + MST + HNC + CV + SHD);
708 UBAGlobals.BAFlagsOUT.Add(IDX + '^' + strFlagsOut );
709 end;
710 end;
711
712
713function StripTFactors(FactorsIN: string):string;
714var strDxCode,strDxName:string;
715begin
716 Result := '';
717 strDxCode := Piece(FactorsIN,U,2);
718 strDxName := Piece(FactorsIN,'(',1);
719 Result := (strDxName + U + strDxCode);
720end;
721
722function AddProviderPatientDaysDx(Dest: TStringList; ProviderIEN: string;PatientIEN: string) : TStringList;
723var i:integer;
724 x: string;
725 tmplst: TStringList;
726begin
727 tmplst := TStringList.Create;
728 tmplst.clear;
729 tCallV(tmplst, 'ORWDBA2 GETDUDC', [ProviderIEN, PatientIEN]);
730
731 try
732 for i := 0 to tmplst.count-1 do
733 x := tmplst.Strings[i];
734 except
735 on EListError do
736 begin
737 {$ifdef debug}Show508Message('EListError in UBACore.AddProviderPatientDaysDx()');{$endif}
738 raise;
739 end;
740 end;
741
742 Result := tmplst;
743end;
744
745
746function OrderRequiresSCEI(pOrderID: string):boolean;
747var i:integer;
748
749begin
750 Result := False;
751
752 try
753 for i := 0 to UBAGlobals.OrderListSCEI.Count-1 do
754 begin
755 if pOrderID = UBAGlobals.OrderListSCEI.Strings[i] then
756 begin
757 Result := True;
758 Break;
759 end;
760 end;
761 except
762 on EListError do
763 begin
764 {$ifdef debug}Show508Message('EListError in UBACore.OrderRequiresSCEI()');{$endif}
765 raise;
766 end;
767 end;
768end;
769
770procedure SaveUnsignedOrders(pOrderRec:String);
771begin
772 // save all unsigned orders, keeping freview and fordersSign in sync
773 // this change may have an impact on response time??????
774 // change from save orders with dx to save all. 06/24/04
775 // / if not clear treatment factors for order is non cidc
776 uBAGlobals.UnsignedOrders.Add(pOrderRec);
777
778end;
779
780function rpcRetrieveSelectedOrderInfo(pOrderIDList: TStringList):TStringList;
781var
782 rList : TStringList;
783 newList:TStringList;
784 i: integer;
785 x: string;
786begin
787 rList := TStringList.Create;
788 newList := TStringList.Create;
789 if Assigned(rList) then rList.Clear;
790 if Assigned(newList) then newList.Clear;
791
792 for i := 0 to pOrderIDList.Count-1 do
793 begin
794 newList.Add(Piece(pOrderIDList.Strings[i],';',1));
795 x := newlist.strings[i];
796 end;
797 if newList.Count > 0 then
798 tCallV(rList,'ORWDBA4 GETTFCI',[newList]);
799 Result := rList;
800
801
802end;
803
804procedure BuildSaveUnsignedList(pOrderList: TStringList);
805var
806 thisList: TStringList;
807 rList: TStringList;
808begin
809
810 thisList := TStringList.Create;
811 rList := TStringList.Create;
812 if Assigned(rList) then rList.Clear;
813 if Assigned(thisList)then thisList.Clear;
814 SaveBillingData(pOrderList); // save unsigned info to be displayed when recalled at later time
815end;
816
817function rpcGetUnsignedOrdersBillingData(pOrderList: TStringList):TStringList;
818var
819 i:integer;
820 newList:TStringList;
821 rList:TStringList;
822begin
823 newList := TStringList.Create;
824 rList := TStringList.Create;
825 if Assigned(newList) then newList.Clear;
826 if Assigned(rList) then rList.Clear;
827 Result := rList;
828
829 if pOrderList.Count = 0 then Exit;
830 for i := 0 to pOrderList.Count-1 do
831 begin
832 newList.Add(Piece(pOrderList.Strings[i],';',1));
833 end;
834 tCallV(rList,'ORWDBA4 GETTFCI',[newList]);
835 Result := rList;
836end;
837
838procedure CompleteUnsignedBillingInfo(pOrderList:TStringList);
839var
840i: integer;
841RecOut : TBADxRecord;
842copyList: TStringList;
843begin
844 copyList := TStringList.Create;
845 if Assigned(copyList) then copyList.Clear;
846
847 if Assigned(BAUnSignedOrders) then BAUnSignedOrders.Clear;
848
849 if not Assigned(UBAGlobals.UnsignedBillingRec) then
850 begin
851 UBAGlobals.UnSignedBillingRec := UBAGlobals.TBAUnsignedBillingRec.Create;
852 UBAGlobals.InitializeUnsignedOrderRec(UBAGlobals.UnsignedBillingRec);
853 end;
854
855 UBAGlobals.InitializeUnsignedOrderRec(UnsignedBillingRec);
856
857 try
858 for i := 0 to pOrderList.Count-1 do
859 begin
860 LoadUnsignedOrderRec(UBAGlobals.UnsignedBillingRec, pOrderList.Strings[i]);
861 if Not UBAGlobals.tempDxNodeExists(UnsignedBillingRec.FBAOrderID) then
862 begin
863 SimpleAddTempDxList(UnSignedBillingRec.FBAOrderID);
864 RecOut := TBADxRecord.Create;
865 RecOut.FExistingRecordID := UnSignedBillingRec.FBAOrderID;
866 RecOut.FBADxCode := UnsignedBillingRec.FBADxCode;
867 RecOut.FBASecDx1 := UnsignedBillingRec.FBASecDx1;
868 RecOut.FBASecDx2 := UnsignedBillingRec.FBASecDx2;
869 RecOut.FBASecDx3 := UnsignedBillingRec.FBASecDx3;
870 RecOut.FTreatmentFactors := UnSignedBillingRec.FBASTSFlags;
871 PutBADxListForOrder(RecOut, RecOut.FExistingRecordID);
872 UBAGlobals.BAUnSignedOrders.Add(UnSignedBillingRec.FBAOrderID + '^' + UnSignedBillingRec.FBASTSFlags);
873 end
874 else
875 begin
876 RecOut := TBADxRecord.Create;
877 if tempDxNodeExists(UnSignedBillingRec.FBAOrderID) then
878 begin
879 GetBADxListForOrder(RecOut, UnSignedBillingRec.FBAOrderID); //load data from source
880 copyList.Add(UnSignedBillingRec.FBAOrderID + '^' + UnSignedBillingRec.FBASTSFlags);
881 BuildSaveUnsignedList(copyList);
882 end;
883 end;
884 end;
885 except
886 on EListError do
887 begin
888 {$ifdef debug}Show508Message('EListError in UBACore.CompleteUnsignedBillingInfo()');{$endif}
889 raise;
890 end;
891 end;
892end;
893
894function GetUnsignedOrderFlags(pOrderID: string; pFlagList: TStringList):string;
895var
896 i: integer;
897begin
898 Result := '';
899 try
900 for i := 0 to pFlagList.Count-1 do
901 begin
902 if pOrderID = Piece(pFlagList.Strings[i],U,1) then
903 begin
904 Result := Piece(pFlagList.Strings[i],U,2); // STSFlags
905 Break;
906 end;
907 end;
908 except
909 on EListError do
910 begin
911 {$ifdef debug}Show508Message('EListError in UBACore.GetUnsignedOrderFlags()');{$endif}
912 raise;
913 end;
914 end;
915
916end;
917
918// BuildTFHintRec is meant to run once, first user of the session
919// contains the information to be displayed while mouse-over in fOrdersSign and fReview.
920procedure BuildTFHintRec;
921var
922hintList :TStringList;
923i: integer;
924x: string;
925begin
926 hintList := TStringList.Create;
927 if Assigned(hintList) then hintList.Clear;
928 hintList := rpcGetTFHintData;
929 if hintList.Count > 0 then UBAGlobals.BAFactorsRec.FBAFactorActive := TRUE;
930
931 try
932 for i := 0 to hintList.Count -1 do
933 begin
934 x := hintList.Strings[i];
935 if piece(x,U,1) = SERVICE_CONNECTED then
936 begin
937 if piece(x,U,2) = '1' then
938 UBAGlobals.BAFactorsRec.FBAFactorSC := Piece(x,U,3)
939 else
940 UBAGlobals.BAFactorsRec.FBAFactorSC := ( UBAGlobals.BAFactorsRec.FBAFactorSC + CRLF + Piece(x,U,3) );
941 end
942 else
943 if piece(x,U,1) = AGENT_ORANGE then
944 begin
945 if piece(x,U,2) = '1' then
946 UBAGlobals.BAFactorsRec.FBAFactorAO := Piece(x,U,3)
947 else
948 UBAGlobals.BAFactorsRec.FBAFactorAO := (UBAGlobals.BAFactorsRec.FBAFactorAO + CRLF + Piece(x,U,3) );
949 end
950 else
951 if piece(x,U,1) = IONIZING_RADIATION then
952 begin
953 if piece(x,U,2) = '1' then
954 UBAGlobals.BAFactorsRec.FBAFactorIR := Piece(x,U,3)
955 else
956 UBAGlobals.BAFactorsRec.FBAFactorIR := (UBAGlobals.BAFactorsRec.FBAFactorIR + CRLF + Piece(x,U,3) );
957 end
958 else
959 if piece(x,U,1) = ENVIRONMENTAL_CONTAM then
960 begin
961 if piece(x,U,2) = '1' then
962 UBAGlobals.BAFactorsRec.FBAFactorEC := Piece(x,U,3)
963 else
964 UBAGlobals.BAFactorsRec.FBAFactorEC := (UBAGlobals.BAFactorsRec.FBAFactorEC + CRLF + Piece(x,U,3) );
965 end
966 else
967 if piece(x,U,1) = HEAD_NECK_CANCER then
968 begin
969 if piece(x,U,2) = '1' then
970 UBAGlobals.BAFactorsRec.FBAFactorHNC := Piece(x,U,3)
971 else
972 UBAGlobals.BAFactorsRec.FBAFactorHNC := (UBAGlobals.BAFactorsRec.FBAFactorHNC + CRLF + Piece(x,U,3) );
973 end
974 else
975 if piece(x,U,1) = MILITARY_SEXUAL_TRAUMA then
976 begin
977 if piece(x,U,2) = '1' then
978 UBAGlobals.BAFactorsRec.FBAFactorMST := Piece(x,U,3)
979 else
980 UBAGlobals.BAFactorsRec.FBAFactorMST := (UBAGlobals.BAFactorsRec.FBAFactorMST + CRLF + Piece(x,U,3) );
981 end
982 else
983 if piece(x,U,1) = COMBAT_VETERAN then
984 begin
985 if piece(x,U,2) = '1' then
986 UBAGlobals.BAFactorsRec.FBAFactorCV := Piece(x,U,3)
987 else
988 UBAGlobals.BAFactorsRec.FBAFactorCV := (UBAGlobals.BAFactorsRec.FBAFactorCV + CRLF + Piece(x,U,3) );
989 end
990 else
991 if piece(x,U,1) = SHIPBOARD_HAZARD_DEFENSE then
992 begin
993 if piece(x,U,2) = '1' then
994 UBAGlobals.BAFactorsRec.FBAFactorSHAD := Piece(x,U,3)
995 else
996 UBAGlobals.BAFactorsRec.FBAFactorSHAD := (UBAGlobals.BAFactorsRec.FBAFactorSHAD + CRLF + Piece(x,U,3) );
997 end;
998 end;
999 except
1000 on EListError do
1001 begin
1002 {$ifdef debug}Show508Message('EListError in UBACore.BuileTFHintRec()');{$endif}
1003 raise;
1004 end;
1005 end;
1006end;
1007
1008
1009function IsAllOrdersNA(pOrderList:TStringList):boolean;
1010var
1011 i:integer;
1012 rList: TStringList;
1013begin
1014 rList := TStringList.Create;
1015 if Assigned(rList) then rList.Clear;
1016 Result := True;// disables dx button
1017
1018 // call returns boolean, orders is billable=1 or nonbillable=0 or discontinued = 0
1019 tCallV(rList,'ORWDBA1 ORPKGTYP',[pOrderList]);
1020
1021 for i := 0 to rList.Count-1 do
1022 begin
1023 if rList.Strings[i] = BILLABLE_ORDER then
1024 begin
1025 Result := False;
1026 Break;
1027 end;
1028 end;
1029end;
1030
1031function PrepOrderID(pOrderID:String): String;
1032var
1033 newOrderID: String;
1034begin
1035 newOrderID := '';
1036 if pos(';',pOrderID) > 0 then
1037 newOrderID := Piece(pOrderID,';',1)
1038 else
1039 newOrderID := pOrderID ;
1040
1041 Result := newOrderID;
1042end;
1043
1044procedure ClearSelectedOrderDiagnoses(pOrderIDList: TStringList);
1045var
1046 RecOut: TBADXRecord;
1047 i: integer;
1048begin
1049 try
1050 for i := 0 to pOrderIDList.Count-1 do
1051 begin
1052 if UBAGlobals.tempDxNodeExists(pOrderIDList.Strings[i]) then
1053 begin
1054 RecOut := TBADxRecord.Create;
1055 GetBADxListForOrder(RecOut, pOrderIDList.Strings[i]);
1056 RecOut.FOrderID := RecOut.FOrderID;
1057 RecOut.FBADxCode := DXREC_INIT_FIELD_VAL;
1058 RecOut.FBASecDx1 := DXREC_INIT_FIELD_VAL;
1059 RecOut.FBASecDx2 := DXREC_INIT_FIELD_VAL;
1060 RecOut.FBASecDx3 := DXREC_INIT_FIELD_VAL;
1061 PutBADxListForOrder(RecOut, pOrderIDList.Strings[i]);
1062 frmReview.lstReview.Refresh;
1063 end;
1064 end;
1065 except
1066 on EListError do
1067 begin
1068 {$ifdef debug}Show508Message('EListError in UBACore.ClearSelectedORdersDiagnoses()');{$endif}
1069 raise;
1070 end;
1071 end;
1072end;
1073
1074procedure LoadConsultOrderRec(var thisRetVal: TBAConsultOrderRec; pOrderID: String; pDxList: TStringList);
1075var
1076 thisString, thisFlags:String;
1077 dx1,dx2,dx3,dx4: string;
1078 i: integer;
1079begin
1080 thisFlags := '';
1081 dx1 := '';
1082 dx2 := '';
1083 dx3 := '';
1084 dx4 := '';
1085 UBAGlobals.BAConsultDxList.Sort;
1086
1087 try
1088 for i := 0 to UBAGlobals.BAConsultDxList.Count -1 do
1089 begin
1090 thisString := UBAGlobals.BAConsultDxList[i];
1091
1092 if i = 0 then
1093 begin
1094 if pos( '(', thisString) > 0 then
1095 begin
1096 thisFlags := Piece(thisString,'(',2);
1097 thisFlags := Piece(thisFlags,')',1);
1098 UBAGlobals.BAConsultPLFlags.Add(pOrderID + U + thisFlags);
1099 dx1 := Piece(thisString,U,2);
1100 dx1 := Piece(dx1,'(',1) + U + Piece(thisString,':',2);
1101 end
1102 else
1103 begin
1104 dx1 := Piece(thisString,U,2);
1105 dx1 := Piece(dx1,':',1)+ U + Piece(thisString,':',2);
1106 end
1107 end
1108 else
1109 if i = 1 then
1110 begin
1111 if pos( '(', thisString) > 0 then
1112 begin
1113 dx2 := Piece(thisString,U,2);
1114 dx2 := Piece(dx2,'(',1)+ U + Piece(thisString,':',2);
1115 end
1116 else
1117 begin
1118 dx2 := Piece(thisString,U,2);
1119 dx2 := Piece(dx2,':',1)+ U + Piece(thisString,':',2);
1120 end
1121 end
1122 else
1123 if i = 2 then
1124 begin
1125 if pos( '(', thisString) > 0 then
1126 begin
1127 dx3 := Piece(thisString,U,2);
1128 dx3 := Piece(dx3,'(',1)+ U + Piece(thisString,':',2);
1129 end
1130 else
1131 begin
1132 dx3 := Piece(thisString,U,2);
1133 dx3 := Piece(dx3,':',1)+ U + Piece(thisString,':',2);
1134 end
1135 end
1136 else
1137 if i = 3 then
1138 begin
1139 if pos( '(', thisString) > 0 then
1140 begin
1141 dx4 := Piece(thisString,U,2);
1142 dx4 := Piece(dx4,'(',1)+ U + Piece(thisString,':',2);
1143 end
1144 else
1145 begin
1146 dx4 := Piece(thisString,U,2);
1147 dx4 := Piece(dx4,':',1)+ U + Piece(thisString,':',2);
1148 end;
1149 end;
1150 end;
1151 except
1152 on EListError do
1153 begin
1154 {$ifdef debug}Show508Message('EListError in UBACore.LoadConsultOrderRec()');{$endif}
1155 raise;
1156 end;
1157 end;
1158
1159 with thisRetVal do
1160 begin
1161 FBAOrderID := pOrderID;
1162 FBATreatmentFactors:= thisFlags;
1163 FBADxCode := dx1;
1164 FBASecDx1 := dx2;
1165 FBASecDx2 := dx3;
1166 FBASecDx3 := dx4;
1167 end;
1168end;
1169
1170procedure LoadTFactorsInRec(var thisRetVal: TBATreatmentFactorsInRec; pOrderID:string; pEligible: string; pTFactors:string);
1171begin
1172 with thisRetVal do
1173 begin
1174 FBAOrderID := pOrderID;
1175 FBAEligible := pEligible;
1176 FBATFactors := pTFactors;
1177 end;
1178end;
1179
1180procedure CompleteConsultOrderRec(pOrderID: string; pDxList: TStringList);
1181var
1182 RecOut : TBADxRecord;
1183 TfFlags,dxRec: string;
1184 orderList : TStringList;
1185 tmpOrderList: TStringList;
1186begin
1187 orderList := TStringList.Create;
1188 tmpOrderList := TStringList.Create;
1189 orderList.Clear;
1190 tmpOrderList.Clear;
1191 if not Assigned(uBAGlobals.ConsultOrderRec)then
1192 begin
1193 UBAGlobals.ConsultOrderRec := UBAGlobals.TBAConsultOrderRec.Create;
1194 InitializeConsultOrderRec(UBAGlobals.ConsultOrderRec);
1195 end
1196 else
1197 InitializeConsultOrderRec(UBAGlobals.ConsultOrderRec);
1198 // call rpc to load list with boolean values based on orders package type.
1199 UBAGlobals.NonBillableOrderList.Clear;
1200 tmpOrderList.Add(UBAGLobals.BAOrderID);
1201 rpcNonBillableOrders(tmpOrderList);
1202 if IsOrderBillable(uBAGlobals.BAOrderID) then
1203 begin
1204 if not UBAGlobals.tempDxNodeExists(uBAGlobals.BAOrderID) then
1205 begin
1206 LoadConsultOrderRec(UBAGlobals.ConsultOrderRec,UBAGlobals.BAOrderID,uBAGlobals.BAConsultDxList);
1207 if NOT UBAGlobals.tempDxNodeExists(pOrderID) then
1208 SimpleAddTempDxList(pOrderID);
1209 RecOut := TBADxRecord.Create;
1210 RecOut.FExistingRecordID := pOrderID;
1211 RecOut.FBADxCode := ConsultOrderRec.FBADxCode;
1212 RecOut.FBASecDx1 := ConsultOrderRec.FBASecDx1;
1213 RecOut.FBASecDx2 := ConsultOrderRec.FBASecDx2;
1214 RecOut.FBASecDx3 := ConsultOrderRec.FBASecDx3;
1215 RecOut.FTreatmentFactors := ConsultOrderRec.FBATreatmentFactors;
1216 PutBADxListForOrder(RecOut, RecOut.FExistingRecordID);
1217// HDS00003380
1218 if IsUserNurseProvider(User.DUZ) then
1219 begin
1220 dxRec := BuildConsultDxRec(ConsultOrderRec);
1221 orderList.Add(RecOut.FExistingRecordID);
1222 // TfFlags := Piece(GetPatientTFactors(orderList),U,2);
1223 TfFlags := GetPatientTFactors(orderList);
1224 TfFlags := ConvertPIMTreatmentFactors(TfFlags);
1225 orderList.Clear;
1226 // if strLen(PChar(dxRec)) > 0 then
1227 // orderList.Add(RecOut.FExistingRecordID +TfFlags + '^'+ BuildConsultDxRec(ConsultOrderRec) )
1228 // else
1229 orderList.Add(RecOut.FExistingRecordID +TfFlags);
1230 SaveBillingData(OrderList); // save unsigned info to be displayed when re
1231 end;
1232 end;
1233 end;
1234end;
1235
1236function GetConsultFlags(pOrderID:String; pFlagList:TStringList;FlagsAsIs:string):string;
1237var
1238 i: integer; //add code to match order id.....
1239begin
1240 Result := '';
1241 for i := 0 to pFlagList.Count -1 do
1242 begin
1243 if pOrderID = Piece(pFlagList.Strings[i],U,1) then
1244 begin
1245 Result := SetConsultFlags( Piece(pFlagList.Strings[i],U,2), FlagsAsIs);
1246 break;
1247 end;
1248 end;
1249
1250end;
1251
1252function SetConsultFlags(pPLFactors: string; pFlagsAsIs:string):string; // return updated flags.
1253var
1254 strFlagsAsIs: string;
1255 strTFactors: string;
1256 strFlagsOut,x: string;
1257
1258begin
1259 strFlagsAsIs := pFlagsAsIs; // flags from pims
1260 strTFactors := pPLFactors; // value selected from problem list
1261 strFlagsOut := ''; // flags updated with selected values from problem list
1262 x := strFlagsAsIs;
1263 Result := '';
1264
1265 UBAGlobals.SC := Copy(x,1,1);
1266 UBAGlobals.AO := Copy(x,2,1);
1267 UBAGlobals.IR := Copy(x,3,1);
1268 UBAGlobals.EC := Copy(x,4,1);
1269 UBAGlobals.MST := Copy(x,5,1);
1270 UBAGlobals.HNC := Copy(x,6,1);
1271 UBAGlobals.CV := Copy(x,7,1); // load factors to global vars;
1272 UBAGlobals.SHD := Copy(x,8,1);
1273
1274 if UBAGlobals.SC <> 'N' then
1275 if StrPos(PChar(strTFactors),PChar(SERVICE_CONNECTED)) <> nil then
1276 UBAGlobals.SC := 'C' ;
1277
1278 if UBAGlobals.SC <> 'N' then
1279 if StrPos(PChar(strTFactors),PChar(NOT_SERVICE_CONNECTED)) <> nil then
1280 UBAGlobals.SC := 'U';
1281
1282 if UBAGlobals.AO <>'N' then
1283 if StrPos(PChar(strTFactors),PChar(AGENT_ORANGE)) <> nil then
1284 UBAGlobals.AO := 'C';
1285
1286 if UBAGlobals.IR <>'N' then
1287 if StrPos(PChar(strTFactors),PChar(IONIZING_RADIATION)) <> nil then
1288 UBAGlobals.IR := 'C';
1289
1290 if UBAGlobals.EC <>'N' then
1291 if StrPos(PChar(strTFactors),PChar(ENVIRONMENTAL_CONTAM)) <> nil then
1292 UBAGlobals.EC := 'C';
1293
1294 if UBAGlobals.MST <>'N' then
1295 if StrPos(PChar(strTFactors),PChar(MILITARY_SEXUAL_TRAUMA)) <> nil then
1296 UBAGlobals.MST := 'C';
1297
1298 if UBAGlobals.HNC <> 'N' then
1299 if StrPos(PChar(strTFactors),PChar(HEAD_NECK_CANCER)) <> nil then
1300 UBAGlobals.HNC := 'C';
1301
1302 if UBAGlobals.CV <>'N' then
1303 if StrPos(PChar(strTFactors),PChar(COMBAT_VETERAN)) <> nil then
1304 UBAGlobals.CV := 'C';
1305
1306 if UBAGlobals.SHD <> 'N' then
1307 if StrPos(PChar(strTFactors),PChar(SHIPBOARD_HAZARD_DEFENSE)) <> nil then
1308 UBAGlobals.SHD := 'C';
1309
1310 strFlagsOut := (UBAGlobals.SC + UBAGlobals.AO + UBAGlobals.IR +
1311 UBAGlobals.EC + UBAGlobals.MST + UBAGlobals.HNC +
1312 UBAGlobals.CV + UBAGlobals.SHD);
1313 Result := strFlagsOut;
1314end;
1315
1316procedure GetBAStatus(pProvider:int64; pPatientDFN: string);
1317begin
1318 // sets global switch, based in value returned from server.
1319 // True -> Billing Aware Switch ON. else OFF
1320
1321 UBACore.rpcSetBillingAwareSwitch(pProvider,pPatientDFN);
1322
1323 if Assigned(UBAGlobals.BAPCEDiagList) then UBAGlobals.BAPCEDiagList.Clear;
1324 frmFrame.SetBADxList;
1325 if not UBAGlobals.BAFactorsRec.FBAFactorActive then
1326 UBACore.BuildTFHintRec;
1327end;
1328
1329function IsICD9CodeActive(ACode: string; LexApp: string; ADate: TFMDateTime = 0): boolean;
1330var
1331 inactiveChar : string;
1332begin
1333 inactiveChar := '#';
1334 if StrPos(PChar(ACode),PChar(inactiveChar) ) <> nil then
1335 ACode := Piece(ACode,'#',1); // remove the '#' added for inactive code.
1336 Result := (sCallV('ORWPCE ACTIVE CODE',[ACode, LexApp, ADate]) = '1');
1337end;
1338
1339function BuildConsultDxRec(ConsultRec: TBAConsultOrderRec): string;
1340var
1341newString: string;
1342begin
1343 if strLen(PChar(ConsultRec.FBADxCode)) > 0 then
1344 newString := Piece(ConsultRec.FBADxCode,U,2)
1345 else
1346 if strLen(PChar(ConsultRec.FBASecDx1)) > 0 then
1347 newString := newString + '^' + Piece(ConsultRec.FBASecDx1,U,2)
1348 else
1349 if strLen(PChar(ConsultRec.FBASecDx2)) > 0 then
1350 newString := newString + '^' + Piece(ConsultRec.FBASecDx2,U,2)
1351 else
1352 if strLen(PChar(ConsultRec.FBASecDx3)) > 0 then
1353 newString := newString + '^' + Piece(ConsultRec.FBASecDx3,U,2);
1354 Result := newString;
1355end;
1356
1357function ConvertPIMTreatmentFactors(pTFactors:string):string;
1358var
1359 strSC,strAO, strIR: string;
1360 strEC, strMST, strHNC, strCV: string;
1361
1362begin
1363 Result := '';
1364 if StrPos(PChar(pTFactors),PChar(SERVICE_CONNECTED)) <> nil then
1365 strSC := '?'
1366 else
1367 strSC := 'N';
1368
1369 if StrPos(PChar(pTFactors),PChar(AGENT_ORANGE)) <> nil then
1370 strAO := '?'
1371 else
1372 strAO := 'N';
1373
1374 if StrPos(PChar(pTFactors),PChar(IONIZING_RADIATION)) <> nil then
1375 strIR := '?'
1376 else
1377 strIR := 'N';
1378
1379 if StrPos(PChar(pTFactors),PChar(ENVIRONMENTAL_CONTAM)) <> nil then
1380 strEC := '?'
1381 else
1382 strEC := 'N';
1383
1384 if StrPos(PChar(pTFactors),PChar(MILITARY_SEXUAL_TRAUMA)) <> nil then
1385 strMST := '?'
1386 else
1387 strMST := 'N';
1388
1389 if StrPos(PChar(pTFactors),PChar(HEAD_NECK_CANCER)) <> nil then
1390 strHNC := '?'
1391 else
1392 strHNC := 'N';
1393
1394 if StrPos(PChar(pTFactors),PChar(COMBAT_VETERAN)) <> nil then
1395 strCV := '?'
1396 else
1397 strCV := 'N';
1398
1399 Result := (strSC + strAO + strIR + strEC + strMST + strHNC + strCV);
1400end;
1401
1402
1403// Delete dc'd orders from BACopiedOrderList to keep things in sync.
1404procedure DeleteDCOrdersFromCopiedList(pOrderID:string);
1405var i:integer;
1406 holdList: TStringList;
1407 x: string;
1408begin
1409 holdList := TStringList.Create;
1410 holdList.Clear;
1411 FastAssign(UBAGlobals.BACopiedOrderFlags, holdList);
1412 UBAGlobals.BACopiedOrderFlags.Clear;
1413 for i := 0 to holdList.Count-1 do
1414 begin
1415 x := Piece(holdList.Strings[i],';',1);
1416 if pOrderID = Piece(holdList.Strings[i],';',1) then
1417 continue
1418 else
1419 UBAGlobals.BACopiedOrderFlags.Add(holdList.Strings[i]);
1420 end;
1421end;
1422
1423procedure UpdateBAConsultOrderList(pDcOrders: TStringList);
1424var
1425 x: string;
1426 var i,j: integer;
1427 holdList : TStringList;
1428begin
1429 // remove order enteries from the dx list that are being discontinued.
1430 for i := 0 to pDcOrders.Count -1 do
1431 begin
1432 UBAGlobals.RemoveOrderFromDxList(pDcOrders.Strings[i]);
1433 end;
1434 if UBAGlobals.BAConsultPLFlags.Count > 0 then
1435 begin
1436 holdList := TStringList.Create;
1437 holdList.Clear;
1438 FastAssign(UBAGlobals.BAConsultPLFlags, holdList);
1439 UBAGlobals.BAConsultPLFlags.Clear;
1440 for i := 0 to holdList.Count-1 do
1441 begin
1442 x := holdList.Strings[i];
1443 for j := 0 to pDcOrders.Count-1 do
1444 begin
1445 if x = pDcOrders.Strings[j] then
1446 continue
1447 else
1448 UBAGlobals.BAConsultPLFlags.Add(x);
1449 end;
1450 end;
1451 end;
1452end;
1453
1454// loop thru CIDC records remove records with invalid orderid
1455function VerifyOrderIdExists(pOrderList: TStringList): TStringList;
1456var
1457 goodList: TStringList;
1458 tOrderID: integer;
1459 i: integer;
1460begin
1461 goodList := TStringList.Create;
1462 goodList.clear;
1463
1464 if pOrderList.Count > 0 then
1465 begin
1466 for i := 0 to pOrderList.Count-1 do
1467 begin
1468 tOrderID := StrToIntDef(Piece(pOrderList.Strings[i],';',1), 0);
1469 if tOrderID > 0 then
1470 goodList.add(pOrderList.Strings[i]);
1471 end;
1472 end;
1473 result := goodList;
1474end;
1475
1476// parse string return Treatment Factors when text inlcudes multiple "(())"
1477//HDS8409
1478function ProcessProblemTFactors(pText:String):String;
1479var AText1,x: string;
1480 i,j: integer;
1481begin
1482 if StrPos(PChar(pText),'(') = nil then exit;
1483 AText1 := Piece(pText,U,2);
1484 i := 1;
1485 j := 0;
1486 while j = 0 do
1487 begin
1488 x := Piece(AText1,'(',i);
1489 if Length(x) > 0 then
1490 inc(i)
1491 else
1492 begin
1493 x := Piece(AText1,'(',i-1);
1494 x := Piece(x,')',1);
1495 j := 1;
1496 Result := x;
1497 end;
1498 end;
1499end;
1500
1501end.
1502
1503
1504
Note: See TracBrowser for help on using the repository browser.