IBP ;ALB/CPM - ARCHIVE/PURGING OPERATIONS ; 17-APR-92
;;2.0;INTEGRATED BILLING;**153**;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 MEANS TEST 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBP 2497 printed Dec 13, 2024@02:26:25 Page 2
IBP ;ALB/CPM - ARCHIVE/PURGING OPERATIONS ; 17-APR-92
+1 ;;2.0;INTEGRATED BILLING;**153**;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 MEANS TEST 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
