- IBP ;ALB/CPM - ARCHIVE/PURGING OPERATIONS ; 17-APR-92
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- FIND ; Entry point to Find Billing Data to Archive
- S IBOP=1 G START
- ;
- ARCHIVE ; Entry point to Archive Billing Data
- S IBOP=2 G START
- ;
- PURGE ; Entry point to Purge Billing Data
- S IBOP=3
- ;
- ;
- START ; Begin search/archive/purge operations.
- I $$NODUZ^IBPU1 G END ; no DUZ code
- I IBOP>1,$$NOESIG^IBPU1(DUZ) G END ; no Electronic Signature Code
- S IBLINE="",$P(IBLINE,"-",80)=""
- ;
- ; - write header
- D HOME^%ZIS
- S IBHDR="*** "_$P("Find^Archive^Purge","^",IBOP)_" Billing Data"_$S(IBOP=1:" to Archive",1:"")_" ***"
- W @IOF,!?80-$L(IBHDR)\2,IBHDR,!
- W !,"This option is used to ",$P("begin the archive process for^archive data from^purge data from","^",IBOP)," the following files:",!
- W !?8,"#350 INTEGRATED BILLING ACTION",!?8,"#351 CATEGORY C BILLING CLOCK",!?8,"#399 BILL/CLAIMS",!!
- I IBOP=1 W "Specify your search criteria for each file. "
- W "The ",$P("search^archiving process^purge process","^",IBOP)," will be queued.",!
- ;
- ; - issue all operational prompts
- K IBD
- 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)
- I '$D(IBD) X "F I=$Y:1:(IOSL-3) W !" S DIR(0)="E" D ^DIR K DIR G END
- ;
- ; - select device if archiving
- I IBOP=2 S %ZIS="N",%ZIS("B")="",%ZIS("A")="Archive entries to what device: " D ^%ZIS G:POP END
- ;
- ; - must enter Electronic Signature to archive or purge
- I IBOP>1,'$$ESIG^IBPU1(DUZ) G END
- ;
- ; - if ok to continue, task off job
- I $$OKAY^IBPU1(IBOP) D TASK^IBPU1
- ;
- END ; - clean up and quit
- D HOME^%ZIS
- K I,IBD,IBHDR,IBLINE,IBOP,J,K,Y
- Q
- ;
- ;
- ;
- QUE ; Tasked Entry point to begin search/archive/purge operations.
- ;
- ; Input: IBD(file number) -- piece 1: date through which to archive
- ; piece 2: log entry if restarting
- ; IBOP -- 1 (Search), 2 (Archive), 3 (Purge)
- ; DUZ -- user ID; retained by Taskman
- ;
- ; - perform operation on each requested file
- S IBF="" F S IBF=$O(IBD(IBF)) Q:'IBF D @("^IBP"_$P("F^A^P","^",IBOP))
- ;
- ; - send confirmation message to user
- D ^IBPUBUL
- ;
- ; - clean up and quit
- K DFN,DATE,IBBDT,IBCNT,IBD,IBDATA,IBEDT,IBF,IBFNAME,IBHDT,IBLINE,IBLOG,IBN,IBOFF,IBOP,IBPAGE,IBROOT,IBSTAT,IBTMDA,IBTMPL,IBRCNO
- Q
- IBP ;ALB/CPM - ARCHIVE/PURGING OPERATIONS ; 17-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 ;
- FIND ; Entry point to Find Billing Data to Archive
- +1 SET IBOP=1
- GOTO START
- +2 ;
- ARCHIVE ; Entry point to Archive Billing Data
- +1 SET IBOP=2
- GOTO START
- +2 ;
- PURGE ; Entry point to Purge Billing Data
- +1 SET IBOP=3
- +2 ;
- +3 ;
- START ; Begin search/archive/purge operations.
- +1 ; no DUZ code
- IF $$NODUZ^IBPU1
- GOTO END
- +2 ; no Electronic Signature Code
- IF IBOP>1
- IF $$NOESIG^IBPU1(DUZ)
- GOTO END
- +3 SET IBLINE=""
- SET $PIECE(IBLINE,"-",80)=""
- +4 ;
- +5 ; - write header
- +6 DO HOME^%ZIS
- +7 SET IBHDR="*** "_$PIECE("Find^Archive^Purge","^",IBOP)_" Billing Data"_$SELECT(IBOP=1:" to Archive",1:"")_" ***"
- +8 WRITE @IOF,!?80-$LENGTH(IBHDR)\2,IBHDR,!
- +9 WRITE !,"This option is used to ",$PIECE("begin the archive process for^archive data from^purge data from","^",IBOP)," the following files:",!
- +10 WRITE !?8,"#350 INTEGRATED BILLING ACTION",!?8,"#351 CATEGORY C BILLING CLOCK",!?8,"#399 BILL/CLAIMS",!!
- +11 IF IBOP=1
- WRITE "Specify your search criteria for each file. "
- +12 WRITE "The ",$PIECE("search^archiving process^purge process","^",IBOP)," will be queued.",!
- +13 ;
- +14 ; - issue all operational prompts
- +15 KILL IBD
- +16 FOR I=350,351,399
- WRITE !,IBLINE
- SET J=$$ASK^IBPU(I,IBOP)
- IF J<0
- GOTO END
- IF J
- SET IBD(I)=""
- IF IBOP=1
- SET K=$$DAT^IBPU
- IF K<0
- GOTO END
- SET IBD(I)=K_"^"_+$PIECE(J,"^",2)
- +17 IF '$DATA(IBD)
- XECUTE "F I=$Y:1:(IOSL-3) W !"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- GOTO END
- +18 ;
- +19 ; - select device if archiving
- +20 IF IBOP=2
- SET %ZIS="N"
- SET %ZIS("B")=""
- SET %ZIS("A")="Archive entries to what device: "
- DO ^%ZIS
- IF POP
- GOTO END
- +21 ;
- +22 ; - must enter Electronic Signature to archive or purge
- +23 IF IBOP>1
- IF '$$ESIG^IBPU1(DUZ)
- GOTO END
- +24 ;
- +25 ; - if ok to continue, task off job
- +26 IF $$OKAY^IBPU1(IBOP)
- DO TASK^IBPU1
- +27 ;
- END ; - clean up and quit
- +1 DO HOME^%ZIS
- +2 KILL I,IBD,IBHDR,IBLINE,IBOP,J,K,Y
- +3 QUIT
- +4 ;
- +5 ;
- +6 ;
- QUE ; Tasked Entry point to begin search/archive/purge operations.
- +1 ;
- +2 ; Input: IBD(file number) -- piece 1: date through which to archive
- +3 ; piece 2: log entry if restarting
- +4 ; IBOP -- 1 (Search), 2 (Archive), 3 (Purge)
- +5 ; DUZ -- user ID; retained by Taskman
- +6 ;
- +7 ; - perform operation on each requested file
- +8 SET IBF=""
- FOR
- SET IBF=$ORDER(IBD(IBF))
- IF 'IBF
- QUIT
- DO @("^IBP"_$PIECE("F^A^P","^",IBOP))
- +9 ;
- +10 ; - send confirmation message to user
- +11 DO ^IBPUBUL
- +12 ;
- +13 ; - clean up and quit
- +14 KILL DFN,DATE,IBBDT,IBCNT,IBD,IBDATA,IBEDT,IBF,IBFNAME,IBHDT,IBLINE,IBLOG,IBN,IBOFF,IBOP,IBPAGE,IBROOT,IBSTAT,IBTMDA,IBTMPL,IBRCNO
- +15 QUIT
