| 1 | IBPA ;ALB/CPM - ARCHIVE BILLING DATA ; 22-APR-92
|
|---|
| 2 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ; Tasked job sorts search template entries by patient and date
|
|---|
| 6 | ; and writes each entry to the archive device.
|
|---|
| 7 | ;
|
|---|
| 8 | ; Input: IBD(file number) -- piece 1: date through which to archive
|
|---|
| 9 | ; piece 2: log entry if restarting
|
|---|
| 10 | ; IBOP -- 2 (Archive Billing Data)
|
|---|
| 11 | ; DUZ -- user ID; retained by Taskman
|
|---|
| 12 | ;
|
|---|
| 13 | ; Called by QUE^IBP
|
|---|
| 14 | ;
|
|---|
| 15 | ;
|
|---|
| 16 | ; Archive entries for each selected 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) F I=2.01,2.02,2.03 D UPD^IBPU1($P(IBD(IBF),"^",2),I,"/@")
|
|---|
| 20 | S IBLOG=$$LOGIEN^IBPU1(IBF),$P(IBD(IBF),"^",3)=IBLOG
|
|---|
| 21 | I 'IBLOG S $P(IBD(IBF),"^",4)="Unable to Retrieve Current Entry to Log File" G END
|
|---|
| 22 | S IBTMPL=$P($G(^IBE(350.6,IBLOG,0)),"^",2)
|
|---|
| 23 | I IBTMPL="" S $P(IBD(IBF),"^",4)="Log Entry has no Search Template" D UPD^IBPU1(IBLOG,.05,"/3") G END
|
|---|
| 24 | S IBTMDA=$O(^DIBT("B",IBTMPL,0))
|
|---|
| 25 | I 'IBTMDA S $P(IBD(IBF),"^",4)="Search Template Name is Invalid" D UPD^IBPU1(IBLOG,.05,"/3") G END
|
|---|
| 26 | 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
|
|---|
| 27 | D UPD^IBPU1(IBLOG,2.01,"NOW") ; set start time of archive
|
|---|
| 28 | ; - sort all entries by patient and date
|
|---|
| 29 | S IBROOT=^DIC(IBF,0,"GL"),IBN=0
|
|---|
| 30 | F S IBN=$O(^DIBT(IBTMDA,1,IBN)) Q:'IBN S DFN=$P($G(@(IBROOT_IBN_",0)")),"^",2),DATE=$S(IBF=350:$P($G(@(IBROOT_IBN_",1)")),"^",2),1:$P($G(@(IBROOT_IBN_",0)")),"^",3)),^TMP($J,"IBPA",+DFN,+DATE,IBN)=""
|
|---|
| 31 | ; - write out the entries
|
|---|
| 32 | D WRITE K ^TMP($J,"IBPA")
|
|---|
| 33 | I 'IBCNT S $P(IBD(IBF),"^",4)="No Entries Archived" D DEL^IBPU1(IBF),UPD^IBPU1(IBLOG,.05,"/3") G END
|
|---|
| 34 | D UPD^IBPU1(IBLOG,.04,IBCNT) ; update log entry with count
|
|---|
| 35 | D UPD^IBPU1(IBLOG,2.02,"NOW") ; set end time of archive in log
|
|---|
| 36 | END Q
|
|---|
| 37 | ;
|
|---|
| 38 | ;
|
|---|
| 39 | WRITE ; Write out each entry.
|
|---|
| 40 | S (DFN,DATE,IBCNT,IBN,IBPAGE)=0,DIC=IBROOT,IBFNAME=$P($G(^DIC(IBF,0)),"^")
|
|---|
| 41 | D NOW^%DTC S IBHDT=$$DAT2^IBOUTL(%)
|
|---|
| 42 | S IBLINE="",$P(IBLINE,"-",IOM)="" D:IBF'=399 HDR
|
|---|
| 43 | F S DFN=$O(^TMP($J,"IBPA",DFN)) Q:'DFN F S DATE=$O(^TMP($J,"IBPA",DFN,DATE)) Q:'DATE F S IBN=$O(^TMP($J,"IBPA",DFN,DATE,IBN)) Q:'IBN D
|
|---|
| 44 | . I IBF=399 D HDR
|
|---|
| 45 | . I IBF'=399 S IBOFF=$S(IBF=350:9,1:11) D:$Y>(IOSL-IBOFF) HDR
|
|---|
| 46 | . S DA=IBN,IBCNT=IBCNT+1 D EN^DIQ
|
|---|
| 47 | Q
|
|---|
| 48 | ;
|
|---|
| 49 | HDR ; Print a short header at the top of each page.
|
|---|
| 50 | S IBPAGE=IBPAGE+1
|
|---|
| 51 | W @IOF,"Archived "_IBFNAME,?(IOM-42),IBHDT,?(IOM-11),"Page: ",IBPAGE,!,IBLINE,!
|
|---|
| 52 | Q
|
|---|
