- IBPF ;ALB/CPM - FIND BILLING DATA TO ARCHIVE ; 20-APR-92
- ;;Version 2.0 ; INTEGRATED BILLING ;; 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 Category C 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
- IBPF ;ALB/CPM - FIND BILLING DATA TO ARCHIVE ; 20-APR-92
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 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 Category C 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