Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBPF

IBPF.m

Go to the documentation of this file.
  1. IBPF ;ALB/CPM - FIND BILLING DATA TO ARCHIVE ; 20-APR-92
  1. ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ; Tasked job which builds search template for each selected Billing
  1. ; data file and populates with eligible records to archive.
  1. ;
  1. ; Input: IBD(file number) -- piece 1: date through which to archive
  1. ; piece 2: log entry if restarting
  1. ; IBOP -- 1 (Find Billing Data to Archive)
  1. ; DUZ -- user ID; retained by Taskman
  1. ;
  1. ; Called by QUE^IBP
  1. ;
  1. ;
  1. ; Perform search of all entries to be archived for each file.
  1. S IBSTAT=$$LOG^IBPU(IBF)
  1. I 'IBSTAT S $P(IBD(IBF),"^",4)="Invalid File to Archive" G END
  1. I $P(IBD(IBF),"^",2) D DEL^IBPU1(IBF),UPD^IBPU1($P(IBD(IBF),"^",2),.05,"/3")
  1. S IBLOG=$$LOGADD^IBPFU(IBF),$P(IBD(IBF),"^",3)=IBLOG
  1. I 'IBLOG S $P(IBD(IBF),"^",4)="Unable to Add Entry to Log File" G END
  1. S IBTMPL=$$TEMPL^IBPFU(IBF,IBLOG)
  1. I 'IBTMPL S $P(IBD(IBF),"^",4)="Unable to Create New Search Template" G END
  1. D UPD^IBPU1(IBLOG,1.01,"NOW") ; set start time of search
  1. S IBEDT=+IBD(IBF) ; set last valid date to select entry
  1. D @$S(IBF=350:"IB^IBPF1",IBF=351:"CLOCK",1:"BILL^IBPF1")
  1. I 'IBCNT S $P(IBD(IBF),"^",4)="No Entries Found to Archive" D DEL^IBPU1(IBF),UPD^IBPU1(IBLOG,.05,"/3") G END
  1. D UPD^IBPU1(IBLOG,.04,IBCNT) ; update log entry with count
  1. D UPD^IBPU1(IBLOG,1.02,"NOW") ; set end time of search in log
  1. END Q
  1. ;
  1. ;
  1. CLOCK ; Find Category C billing clocks which may be purged.
  1. ; Input: IBTMPL -- Search template to store entries
  1. ; IBEDT -- Last date for which a clock may be purged
  1. ; Output: IBCNT -- number of records stored
  1. S X1=IBEDT,X2=-364 D C^%DTC S IBBDT=X
  1. ;
  1. ; - cancelled and closed clocks which 'end' on or before the
  1. ; - 'Purge End Date,' or 'start' on or before the 'Purge Start
  1. ; - Date' are eligible for archiving/purging.
  1. ;
  1. S (DFN,IBCLDA)=0,IBCNT=0
  1. F S DFN=$O(^IBE(351,"AIVDT",DFN)) Q:'DFN S IBDATE=-(IBEDT+.1) D
  1. . F S IBDATE=$O(^IBE(351,"AIVDT",DFN,IBDATE)) Q:'IBDATE D
  1. .. F S IBCLDA=$O(^IBE(351,"AIVDT",DFN,IBDATE,IBCLDA)) Q:'IBCLDA D
  1. ... S IBCLND=$G(^IBE(351,+IBCLDA,0)) I IBCLND="" D KILL Q
  1. ... Q:$P(IBCLND,"^",4)=1 ; Clock is still active
  1. ... I '$P(IBCLND,"^",10) Q:$P(IBCLND,"^",3)>IBBDT
  1. ... E Q:$P(IBCLND,"^",10)>IBEDT
  1. ... S IBCNT=IBCNT+1,^DIBT(IBTMPL,1,IBCLDA)="" ; store in template
  1. ;
  1. ; - kill variables and quit.
  1. K IBDATE,DFN,IBCLDA,IBCLND,IBBDT,X,X1,X2
  1. Q
  1. ;
  1. KILL ; Kill leftover cross-references for a missing entry.
  1. K ^IBE(351,IBCLDA,0),^(1)
  1. K ^IBE(351,"ACT",DFN,IBCLDA)
  1. K ^IBE(351,"AIVDT",DFN,DATE,IBCLDA)
  1. K ^IBE(351,"B",IBSITE_IBCLDA,IBCLDA)
  1. K ^IBE(351,"C",DFN,IBCLDA)
  1. Q