| 1 | IBP ;ALB/CPM - ARCHIVE/PURGING OPERATIONS ; 17-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 | FIND ; Entry point to Find Billing Data to Archive
|
|---|
| 6 | S IBOP=1 G START
|
|---|
| 7 | ;
|
|---|
| 8 | ARCHIVE ; Entry point to Archive Billing Data
|
|---|
| 9 | S IBOP=2 G START
|
|---|
| 10 | ;
|
|---|
| 11 | PURGE ; Entry point to Purge Billing Data
|
|---|
| 12 | S IBOP=3
|
|---|
| 13 | ;
|
|---|
| 14 | ;
|
|---|
| 15 | START ; Begin search/archive/purge operations.
|
|---|
| 16 | I $$NODUZ^IBPU1 G END ; no DUZ code
|
|---|
| 17 | I IBOP>1,$$NOESIG^IBPU1(DUZ) G END ; no Electronic Signature Code
|
|---|
| 18 | S IBLINE="",$P(IBLINE,"-",80)=""
|
|---|
| 19 | ;
|
|---|
| 20 | ; - write header
|
|---|
| 21 | D HOME^%ZIS
|
|---|
| 22 | S IBHDR="*** "_$P("Find^Archive^Purge","^",IBOP)_" Billing Data"_$S(IBOP=1:" to Archive",1:"")_" ***"
|
|---|
| 23 | W @IOF,!?80-$L(IBHDR)\2,IBHDR,!
|
|---|
| 24 | W !,"This option is used to ",$P("begin the archive process for^archive data from^purge data from","^",IBOP)," the following files:",!
|
|---|
| 25 | W !?8,"#350 INTEGRATED BILLING ACTION",!?8,"#351 MEANS TEST BILLING CLOCK",!?8,"#399 BILL/CLAIMS",!!
|
|---|
| 26 | I IBOP=1 W "Specify your search criteria for each file. "
|
|---|
| 27 | W "The ",$P("search^archiving process^purge process","^",IBOP)," will be queued.",!
|
|---|
| 28 | ;
|
|---|
| 29 | ; - issue all operational prompts
|
|---|
| 30 | K IBD
|
|---|
| 31 | F I=350,351,399 W !,IBLINE S J=$$ASK^IBPU(I,IBOP) G:J<0 END I J S IBD(I)="" I IBOP=1 S K=$$DAT^IBPU G:K<0 END S IBD(I)=K_"^"_+$P(J,"^",2)
|
|---|
| 32 | I '$D(IBD) X "F I=$Y:1:(IOSL-3) W !" S DIR(0)="E" D ^DIR K DIR G END
|
|---|
| 33 | ;
|
|---|
| 34 | ; - select device if archiving
|
|---|
| 35 | I IBOP=2 S %ZIS="N",%ZIS("B")="",%ZIS("A")="Archive entries to what device: " D ^%ZIS G:POP END
|
|---|
| 36 | ;
|
|---|
| 37 | ; - must enter Electronic Signature to archive or purge
|
|---|
| 38 | I IBOP>1,'$$ESIG^IBPU1(DUZ) G END
|
|---|
| 39 | ;
|
|---|
| 40 | ; - if ok to continue, task off job
|
|---|
| 41 | I $$OKAY^IBPU1(IBOP) D TASK^IBPU1
|
|---|
| 42 | ;
|
|---|
| 43 | END ; - clean up and quit
|
|---|
| 44 | D HOME^%ZIS
|
|---|
| 45 | K I,IBD,IBHDR,IBLINE,IBOP,J,K,Y
|
|---|
| 46 | Q
|
|---|
| 47 | ;
|
|---|
| 48 | ;
|
|---|
| 49 | ;
|
|---|
| 50 | QUE ; Tasked Entry point to begin search/archive/purge operations.
|
|---|
| 51 | ;
|
|---|
| 52 | ; Input: IBD(file number) -- piece 1: date through which to archive
|
|---|
| 53 | ; piece 2: log entry if restarting
|
|---|
| 54 | ; IBOP -- 1 (Search), 2 (Archive), 3 (Purge)
|
|---|
| 55 | ; DUZ -- user ID; retained by Taskman
|
|---|
| 56 | ;
|
|---|
| 57 | ; - perform operation on each requested file
|
|---|
| 58 | S IBF="" F S IBF=$O(IBD(IBF)) Q:'IBF D @("^IBP"_$P("F^A^P","^",IBOP))
|
|---|
| 59 | ;
|
|---|
| 60 | ; - send confirmation message to user
|
|---|
| 61 | D ^IBPUBUL
|
|---|
| 62 | ;
|
|---|
| 63 | ; - clean up and quit
|
|---|
| 64 | K DFN,DATE,IBBDT,IBCNT,IBD,IBDATA,IBEDT,IBF,IBFNAME,IBHDT,IBLINE,IBLOG,IBN,IBOFF,IBOP,IBPAGE,IBROOT,IBSTAT,IBTMDA,IBTMPL,IBRCNO
|
|---|
| 65 | Q
|
|---|
