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

IBPP.m

Go to the documentation of this file.
  1. IBPP ;ALB/CPM - PURGE BILLING DATA ; 22-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 inverts search template entries and deletes them from
  1. ; the source file.
  1. ;
  1. ; Input: IBD(file number) -- piece 1: date through which to archive
  1. ; IBOP -- 3 (Purge Billing Data)
  1. ; DUZ -- user ID; retained by Taskman
  1. ;
  1. ; Called by QUE^IBP
  1. ;
  1. ;
  1. ; Purge entries for each selected file.
  1. S IBSTAT=$$LOG^IBPU(IBF)
  1. I 'IBSTAT S $P(IBD(IBF),"^",4)="Invalid File to Purge" G END
  1. S IBLOG=$$LOGIEN^IBPU1(IBF),$P(IBD(IBF),"^",3)=IBLOG
  1. I 'IBLOG S $P(IBD(IBF),"^",4)="Unable to Retrieve Current Entry to Log File" G END
  1. S IBTMPL=$P($G(^IBE(350.6,IBLOG,0)),"^",2)
  1. I IBTMPL="" S $P(IBD(IBF),"^",4)="Log Entry has no Search Template" D UPD^IBPU1(IBLOG,.05,"/3") G END
  1. S IBTMDA=$O(^DIBT("B",IBTMPL,0))
  1. I 'IBTMDA S $P(IBD(IBF),"^",4)="Search Template Name is Invalid" D UPD^IBPU1(IBLOG,.05,"/3") G END
  1. 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
  1. D UPD^IBPU1(IBLOG,3.01,"NOW") ; set start time of purge
  1. ; - "invert" search template entries
  1. S IBN=0 F S IBN=$O(^DIBT(IBTMDA,1,IBN)) Q:'IBN S ^TMP($J,"IBPP",-IBN)=""
  1. ; - purge the entries
  1. 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
  1. K ^TMP($J,"IBPP")
  1. I 'IBCNT S $P(IBD(IBF),"^",4)="No Entries Purged" 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,3.02,"NOW") ; set end time of purge in log
  1. D UPD^IBPU1(IBLOG,.05,"/2") ; close out log entry
  1. D DEL^IBPU1(IBF) ; delete search template
  1. END Q
  1. NEWV ;
  1. N DA,DIE,DIK
  1. D ^IBPU2
  1. Q