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