IBP.m

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