| 1 | IBPP ;ALB/CPM - PURGE BILLING DATA ; 22-APR-92
|
|---|
| 2 | ;;Version 2.0 ; INTEGRATED BILLING ;**48**; 21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ; Tasked job inverts search template entries and deletes them from
|
|---|
| 6 | ; the source file.
|
|---|
| 7 | ;
|
|---|
| 8 | ; Input: IBD(file number) -- piece 1: date through which to archive
|
|---|
| 9 | ; IBOP -- 3 (Purge Billing Data)
|
|---|
| 10 | ; DUZ -- user ID; retained by Taskman
|
|---|
| 11 | ;
|
|---|
| 12 | ; Called by QUE^IBP
|
|---|
| 13 | ;
|
|---|
| 14 | ;
|
|---|
| 15 | ; Purge entries for each selected file.
|
|---|
| 16 | I '$O(^IBE(356.8,"B","OTHER",0)) S $P(IBD(IBF),"^",4)="Error: Reason Not Billable of OTHER undefined, no bills purged" G END
|
|---|
| 17 | I '$O(^IBE(356.8,"B","BILL PURGED",0)) S $P(IBD(IBF),"^",4)="Error: Reason Not Billable of BILL PURGED undefined, no bills purged" G END
|
|---|
| 18 | ;
|
|---|
| 19 | S IBSTAT=$$LOG^IBPU(IBF)
|
|---|
| 20 | I 'IBSTAT S $P(IBD(IBF),"^",4)="Invalid File to Purge" G END
|
|---|
| 21 | S IBLOG=$$LOGIEN^IBPU1(IBF),$P(IBD(IBF),"^",3)=IBLOG
|
|---|
| 22 | I 'IBLOG S $P(IBD(IBF),"^",4)="Unable to Retrieve Current Entry to Log File" G END
|
|---|
| 23 | S IBTMPL=$P($G(^IBE(350.6,IBLOG,0)),"^",2)
|
|---|
| 24 | I IBTMPL="" S $P(IBD(IBF),"^",4)="Log Entry has no Search Template" D UPD^IBPU1(IBLOG,.05,"/3") G END
|
|---|
| 25 | S IBTMDA=$O(^DIBT("B",IBTMPL,0))
|
|---|
| 26 | I 'IBTMDA S $P(IBD(IBF),"^",4)="Search Template Name is Invalid" D UPD^IBPU1(IBLOG,.05,"/3") G END
|
|---|
| 27 | I '$D(^DIBT(IBTMDA,1)) S $P(IBD(IBF),"^",4)="Search Template has no Entries to Archive" D UPD^IBPU1(IBLOG,.05,"/3") G END
|
|---|
| 28 | D UPD^IBPU1(IBLOG,3.01,"NOW") ; set start time of purge
|
|---|
| 29 | ; - "invert" search template entries
|
|---|
| 30 | S IBN=0 F S IBN=$O(^DIBT(IBTMDA,1,IBN)) Q:'IBN S ^TMP($J,"IBPP",-IBN)=""
|
|---|
| 31 | ; - purge the entries
|
|---|
| 32 | S DIK=^DIC(IBF,0,"GL"),IBCNT=0,IBRCNO="" F S IBRCNO=$O(^TMP($J,"IBPP",IBRCNO)) Q:IBRCNO="" S (DA,IBN)=-IBRCNO,IBCNT=IBCNT+1 D:IBF=399 NEWV D ^DIK
|
|---|
| 33 | ;
|
|---|
| 34 | D RNB K ^TMP($J,"IBPP"),^TMP($J,"IBPPTRN")
|
|---|
| 35 | ;
|
|---|
| 36 | I 'IBCNT S $P(IBD(IBF),"^",4)="No Entries Purged" D DEL^IBPU1(IBF),UPD^IBPU1(IBLOG,.05,"/3") G END
|
|---|
| 37 | D UPD^IBPU1(IBLOG,.04,IBCNT) ; update log entry with count
|
|---|
| 38 | D UPD^IBPU1(IBLOG,3.02,"NOW") ; set end time of purge in log
|
|---|
| 39 | D UPD^IBPU1(IBLOG,.05,"/2") ; close out log entry
|
|---|
| 40 | D DEL^IBPU1(IBF) ; delete search template
|
|---|
| 41 | END Q
|
|---|
| 42 | NEWV ;
|
|---|
| 43 | N DA,DIE,DIK
|
|---|
| 44 | D ^IBPU2
|
|---|
| 45 | Q
|
|---|
| 46 | RNB ; adds RNB (356,.19) of OTHER to all CT records that were on an archived bill but do not yet have a RNB
|
|---|
| 47 | ; this covers visits where the bill was canceled or the visit was removed from a bill
|
|---|
| 48 | ; all CT records that were actually billed on an archived bill should already have a RNB of BILL PURGED
|
|---|
| 49 | N IBTRN,IBX,DIE,DA,DR,DIC,IBRNB S IBRNB=$O(^IBE(356.8,"B","OTHER",0)) Q:'IBRNB
|
|---|
| 50 | S IBTRN=0 F S IBTRN=$O(^TMP($J,"IBPPTRN",IBTRN)) Q:'IBTRN D
|
|---|
| 51 | . S IBX=$G(^IBT(356,+IBTRN,0)) I +IBX,'$P(IBX,U,19) S DIE="^IBT(356,",DA=IBTRN,DR=".19////"_IBRNB D ^DIE
|
|---|
| 52 | Q
|
|---|
