- 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 Mar 13, 2025@21:31:35 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
