IBPF ;ALB/CPM - FIND BILLING DATA TO ARCHIVE ; 20-APR-92
;;2.0;INTEGRATED BILLING;**153**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Tasked job which builds search template for each selected Billing
; data file and populates with eligible records to archive.
;
; Input: IBD(file number) -- piece 1: date through which to archive
; piece 2: log entry if restarting
; IBOP -- 1 (Find Billing Data to Archive)
; DUZ -- user ID; retained by Taskman
;
; Called by QUE^IBP
;
;
; Perform search of all entries to be archived for each file.
S IBSTAT=$$LOG^IBPU(IBF)
I 'IBSTAT S $P(IBD(IBF),"^",4)="Invalid File to Archive" G END
I $P(IBD(IBF),"^",2) D DEL^IBPU1(IBF),UPD^IBPU1($P(IBD(IBF),"^",2),.05,"/3")
S IBLOG=$$LOGADD^IBPFU(IBF),$P(IBD(IBF),"^",3)=IBLOG
I 'IBLOG S $P(IBD(IBF),"^",4)="Unable to Add Entry to Log File" G END
S IBTMPL=$$TEMPL^IBPFU(IBF,IBLOG)
I 'IBTMPL S $P(IBD(IBF),"^",4)="Unable to Create New Search Template" G END
D UPD^IBPU1(IBLOG,1.01,"NOW") ; set start time of search
S IBEDT=+IBD(IBF) ; set last valid date to select entry
D @$S(IBF=350:"IB^IBPF1",IBF=351:"CLOCK",1:"BILL^IBPF1")
I 'IBCNT S $P(IBD(IBF),"^",4)="No Entries Found to Archive" 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,1.02,"NOW") ; set end time of search in log
END Q
;
;
CLOCK ; Find Means Test billing clocks which may be purged.
; Input: IBTMPL -- Search template to store entries
; IBEDT -- Last date for which a clock may be purged
; Output: IBCNT -- number of records stored
S X1=IBEDT,X2=-364 D C^%DTC S IBBDT=X
;
; - cancelled and closed clocks which 'end' on or before the
; - 'Purge End Date,' or 'start' on or before the 'Purge Start
; - Date' are eligible for archiving/purging.
;
S (DFN,IBCLDA)=0,IBCNT=0
F S DFN=$O(^IBE(351,"AIVDT",DFN)) Q:'DFN S IBDATE=-(IBEDT+.1) D
. F S IBDATE=$O(^IBE(351,"AIVDT",DFN,IBDATE)) Q:'IBDATE D
.. F S IBCLDA=$O(^IBE(351,"AIVDT",DFN,IBDATE,IBCLDA)) Q:'IBCLDA D
... S IBCLND=$G(^IBE(351,+IBCLDA,0)) I IBCLND="" D KILL Q
... Q:$P(IBCLND,"^",4)=1 ; Clock is still active
... I '$P(IBCLND,"^",10) Q:$P(IBCLND,"^",3)>IBBDT
... E Q:$P(IBCLND,"^",10)>IBEDT
... S IBCNT=IBCNT+1,^DIBT(IBTMPL,1,IBCLDA)="" ; store in template
;
; - kill variables and quit.
K IBDATE,DFN,IBCLDA,IBCLND,IBBDT,X,X1,X2
Q
;
KILL ; Kill leftover cross-references for a missing entry.
K ^IBE(351,IBCLDA,0),^(1)
K ^IBE(351,"ACT",DFN,IBCLDA)
K ^IBE(351,"AIVDT",DFN,DATE,IBCLDA)
K ^IBE(351,"B",IBSITE_IBCLDA,IBCLDA)
K ^IBE(351,"C",DFN,IBCLDA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBPF 2812 printed Sep 23, 2025@20:02:50 Page 2
IBPF ;ALB/CPM - FIND BILLING DATA TO ARCHIVE ; 20-APR-92
+1 ;;2.0;INTEGRATED BILLING;**153**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; Tasked job which builds search template for each selected Billing
+5 ; data file and populates with eligible records to archive.
+6 ;
+7 ; Input: IBD(file number) -- piece 1: date through which to archive
+8 ; piece 2: log entry if restarting
+9 ; IBOP -- 1 (Find Billing Data to Archive)
+10 ; DUZ -- user ID; retained by Taskman
+11 ;
+12 ; Called by QUE^IBP
+13 ;
+14 ;
+15 ; Perform search of all entries to be archived for each file.
+16 SET IBSTAT=$$LOG^IBPU(IBF)
+17 IF 'IBSTAT
SET $PIECE(IBD(IBF),"^",4)="Invalid File to Archive"
GOTO END
+18 IF $PIECE(IBD(IBF),"^",2)
DO DEL^IBPU1(IBF)
DO UPD^IBPU1($PIECE(IBD(IBF),"^",2),.05,"/3")
+19 SET IBLOG=$$LOGADD^IBPFU(IBF)
SET $PIECE(IBD(IBF),"^",3)=IBLOG
+20 IF 'IBLOG
SET $PIECE(IBD(IBF),"^",4)="Unable to Add Entry to Log File"
GOTO END
+21 SET IBTMPL=$$TEMPL^IBPFU(IBF,IBLOG)
+22 IF 'IBTMPL
SET $PIECE(IBD(IBF),"^",4)="Unable to Create New Search Template"
GOTO END
+23 ; set start time of search
DO UPD^IBPU1(IBLOG,1.01,"NOW")
+24 ; set last valid date to select entry
SET IBEDT=+IBD(IBF)
+25 DO @$SELECT(IBF=350:"IB^IBPF1",IBF=351:"CLOCK",1:"BILL^IBPF1")
+26 IF 'IBCNT
SET $PIECE(IBD(IBF),"^",4)="No Entries Found to Archive"
DO DEL^IBPU1(IBF)
DO UPD^IBPU1(IBLOG,.05,"/3")
GOTO END
+27 ; update log entry with count
DO UPD^IBPU1(IBLOG,.04,IBCNT)
+28 ; set end time of search in log
DO UPD^IBPU1(IBLOG,1.02,"NOW")
END QUIT
+1 ;
+2 ;
CLOCK ; Find Means Test billing clocks which may be purged.
+1 ; Input: IBTMPL -- Search template to store entries
+2 ; IBEDT -- Last date for which a clock may be purged
+3 ; Output: IBCNT -- number of records stored
+4 SET X1=IBEDT
SET X2=-364
DO C^%DTC
SET IBBDT=X
+5 ;
+6 ; - cancelled and closed clocks which 'end' on or before the
+7 ; - 'Purge End Date,' or 'start' on or before the 'Purge Start
+8 ; - Date' are eligible for archiving/purging.
+9 ;
+10 SET (DFN,IBCLDA)=0
SET IBCNT=0
+11 FOR
SET DFN=$ORDER(^IBE(351,"AIVDT",DFN))
if 'DFN
QUIT
SET IBDATE=-(IBEDT+.1)
Begin DoDot:1
+12 FOR
SET IBDATE=$ORDER(^IBE(351,"AIVDT",DFN,IBDATE))
if 'IBDATE
QUIT
Begin DoDot:2
+13 FOR
SET IBCLDA=$ORDER(^IBE(351,"AIVDT",DFN,IBDATE,IBCLDA))
if 'IBCLDA
QUIT
Begin DoDot:3
+14 SET IBCLND=$GET(^IBE(351,+IBCLDA,0))
IF IBCLND=""
DO KILL
QUIT
+15 ; Clock is still active
if $PIECE(IBCLND,"^",4)=1
QUIT
+16 IF '$PIECE(IBCLND,"^",10)
if $PIECE(IBCLND,"^",3)>IBBDT
QUIT
+17 IF '$TEST
if $PIECE(IBCLND,"^",10)>IBEDT
QUIT
+18 ; store in template
SET IBCNT=IBCNT+1
SET ^DIBT(IBTMPL,1,IBCLDA)=""
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 ; - kill variables and quit.
+21 KILL IBDATE,DFN,IBCLDA,IBCLND,IBBDT,X,X1,X2
+22 QUIT
+23 ;
KILL ; Kill leftover cross-references for a missing entry.
+1 KILL ^IBE(351,IBCLDA,0),^(1)
+2 KILL ^IBE(351,"ACT",DFN,IBCLDA)
+3 KILL ^IBE(351,"AIVDT",DFN,DATE,IBCLDA)
+4 KILL ^IBE(351,"B",IBSITE_IBCLDA,IBCLDA)
+5 KILL ^IBE(351,"C",DFN,IBCLDA)
+6 QUIT
