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