| 1 | IBPF ;ALB/CPM - FIND BILLING DATA TO ARCHIVE ; 20-APR-92
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**153**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ; Tasked job which builds search template for each selected Billing
|
|---|
| 6 | ; data file and populates with eligible records to archive.
|
|---|
| 7 | ;
|
|---|
| 8 | ; Input: IBD(file number) -- piece 1: date through which to archive
|
|---|
| 9 | ; piece 2: log entry if restarting
|
|---|
| 10 | ; IBOP -- 1 (Find Billing Data to Archive)
|
|---|
| 11 | ; DUZ -- user ID; retained by Taskman
|
|---|
| 12 | ;
|
|---|
| 13 | ; Called by QUE^IBP
|
|---|
| 14 | ;
|
|---|
| 15 | ;
|
|---|
| 16 | ; Perform search of all entries to be archived for each file.
|
|---|
| 17 | S IBSTAT=$$LOG^IBPU(IBF)
|
|---|
| 18 | I 'IBSTAT S $P(IBD(IBF),"^",4)="Invalid File to Archive" G END
|
|---|
| 19 | I $P(IBD(IBF),"^",2) D DEL^IBPU1(IBF),UPD^IBPU1($P(IBD(IBF),"^",2),.05,"/3")
|
|---|
| 20 | S IBLOG=$$LOGADD^IBPFU(IBF),$P(IBD(IBF),"^",3)=IBLOG
|
|---|
| 21 | I 'IBLOG S $P(IBD(IBF),"^",4)="Unable to Add Entry to Log File" G END
|
|---|
| 22 | S IBTMPL=$$TEMPL^IBPFU(IBF,IBLOG)
|
|---|
| 23 | I 'IBTMPL S $P(IBD(IBF),"^",4)="Unable to Create New Search Template" G END
|
|---|
| 24 | D UPD^IBPU1(IBLOG,1.01,"NOW") ; set start time of search
|
|---|
| 25 | S IBEDT=+IBD(IBF) ; set last valid date to select entry
|
|---|
| 26 | D @$S(IBF=350:"IB^IBPF1",IBF=351:"CLOCK",1:"BILL^IBPF1")
|
|---|
| 27 | I 'IBCNT S $P(IBD(IBF),"^",4)="No Entries Found to Archive" D DEL^IBPU1(IBF),UPD^IBPU1(IBLOG,.05,"/3") G END
|
|---|
| 28 | D UPD^IBPU1(IBLOG,.04,IBCNT) ; update log entry with count
|
|---|
| 29 | D UPD^IBPU1(IBLOG,1.02,"NOW") ; set end time of search in log
|
|---|
| 30 | END Q
|
|---|
| 31 | ;
|
|---|
| 32 | ;
|
|---|
| 33 | CLOCK ; Find Means Test billing clocks which may be purged.
|
|---|
| 34 | ; Input: IBTMPL -- Search template to store entries
|
|---|
| 35 | ; IBEDT -- Last date for which a clock may be purged
|
|---|
| 36 | ; Output: IBCNT -- number of records stored
|
|---|
| 37 | S X1=IBEDT,X2=-364 D C^%DTC S IBBDT=X
|
|---|
| 38 | ;
|
|---|
| 39 | ; - cancelled and closed clocks which 'end' on or before the
|
|---|
| 40 | ; - 'Purge End Date,' or 'start' on or before the 'Purge Start
|
|---|
| 41 | ; - Date' are eligible for archiving/purging.
|
|---|
| 42 | ;
|
|---|
| 43 | S (DFN,IBCLDA)=0,IBCNT=0
|
|---|
| 44 | F S DFN=$O(^IBE(351,"AIVDT",DFN)) Q:'DFN S IBDATE=-(IBEDT+.1) D
|
|---|
| 45 | . F S IBDATE=$O(^IBE(351,"AIVDT",DFN,IBDATE)) Q:'IBDATE D
|
|---|
| 46 | .. F S IBCLDA=$O(^IBE(351,"AIVDT",DFN,IBDATE,IBCLDA)) Q:'IBCLDA D
|
|---|
| 47 | ... S IBCLND=$G(^IBE(351,+IBCLDA,0)) I IBCLND="" D KILL Q
|
|---|
| 48 | ... Q:$P(IBCLND,"^",4)=1 ; Clock is still active
|
|---|
| 49 | ... I '$P(IBCLND,"^",10) Q:$P(IBCLND,"^",3)>IBBDT
|
|---|
| 50 | ... E Q:$P(IBCLND,"^",10)>IBEDT
|
|---|
| 51 | ... S IBCNT=IBCNT+1,^DIBT(IBTMPL,1,IBCLDA)="" ; store in template
|
|---|
| 52 | ;
|
|---|
| 53 | ; - kill variables and quit.
|
|---|
| 54 | K IBDATE,DFN,IBCLDA,IBCLND,IBBDT,X,X1,X2
|
|---|
| 55 | Q
|
|---|
| 56 | ;
|
|---|
| 57 | KILL ; Kill leftover cross-references for a missing entry.
|
|---|
| 58 | K ^IBE(351,IBCLDA,0),^(1)
|
|---|
| 59 | K ^IBE(351,"ACT",DFN,IBCLDA)
|
|---|
| 60 | K ^IBE(351,"AIVDT",DFN,DATE,IBCLDA)
|
|---|
| 61 | K ^IBE(351,"B",IBSITE_IBCLDA,IBCLDA)
|
|---|
| 62 | K ^IBE(351,"C",DFN,IBCLDA)
|
|---|
| 63 | Q
|
|---|
