IBPP.m

IBPP	;ALB/CPM - PURGE 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 inverts search template entries and deletes them from

	; the source file.

	;

	;  Input:  IBD(file number) --  piece 1:  date through which to archive

	;                      IBOP --  3 (Purge Billing Data)

	;                       DUZ --  user ID; retained by Taskman

	;

	;  Called by QUE^IBP

	;

	;

	; Purge entries for each selected file. 

	S IBSTAT=$$LOG^IBPU(IBF)

	I 'IBSTAT S $P(IBD(IBF),"^",4)="Invalid File to Purge" G END

	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,3.01,"NOW") ; set start time of purge

	; - "invert" search template entries

	S IBN=0 F  S IBN=$O(^DIBT(IBTMDA,1,IBN)) Q:'IBN  S ^TMP($J,"IBPP",-IBN)=""

	; - purge the entries

	S DIK=^DIC(IBF,0,"GL"),IBCNT=0,IBRCNO="" F  S IBRCNO=$O(^TMP($J,"IBPP",IBRCNO)) Q:IBRCNO=""  S (DA,IBN)=-IBRCNO,IBCNT=IBCNT+1 D:IBF=399 NEWV D ^DIK

	K ^TMP($J,"IBPP")

	I 'IBCNT S $P(IBD(IBF),"^",4)="No Entries Purged" 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,3.02,"NOW") ; set end time of purge in log

	D UPD^IBPU1(IBLOG,.05,"/2") ; close out log entry

	D DEL^IBPU1(IBF) ; delete search template

END	Q

NEWV	;

	N DA,DIE,DIK

	D ^IBPU2

	Q

IBPP      ;ALB/CPM - PURGE 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 inverts search template entries and deletes them from

 +5       ; the source file.

 +6       ;

 +7       ;  Input:  IBD(file number) --  piece 1:  date through which to archive

 +8       ;                      IBOP --  3 (Purge Billing Data)

 +9       ;                       DUZ --  user ID; retained by Taskman

 +10      ;

 +11      ;  Called by QUE^IBP

 +12      ;

 +13      ;

 +14      ; Purge entries for each selected file. 

 +15       SET IBSTAT=$$LOG^IBPU(IBF)

 +16       IF 'IBSTAT

               SET $PIECE(IBD(IBF),"^",4)="Invalid File to Purge"

               GOTO END

 +17       SET IBLOG=$$LOGIEN^IBPU1(IBF)

           SET $PIECE(IBD(IBF),"^",3)=IBLOG

 +18       IF 'IBLOG

               SET $PIECE(IBD(IBF),"^",4)="Unable to Retrieve Current Entry to Log File"

               GOTO END

 +19       SET IBTMPL=$PIECE($GET(^IBE(350.6,IBLOG,0)),"^",2)

 +20       IF IBTMPL=""

               SET $PIECE(IBD(IBF),"^",4)="Log Entry has no Search Template"

               DO UPD^IBPU1(IBLOG,.05,"/3")

               GOTO END

 +21       SET IBTMDA=$ORDER(^DIBT("B",IBTMPL,0))

 +22       IF 'IBTMDA

               SET $PIECE(IBD(IBF),"^",4)="Search Template Name is Invalid"

               DO UPD^IBPU1(IBLOG,.05,"/3")

               GOTO END

 +23       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

 +24      ; set start time of purge

           DO UPD^IBPU1(IBLOG,3.01,"NOW")

 +25      ; - "invert" search template entries

 +26       SET IBN=0

           FOR 

               SET IBN=$ORDER(^DIBT(IBTMDA,1,IBN))

               IF 'IBN

                   QUIT 

               SET ^TMP($JOB,"IBPP",-IBN)=""

 +27      ; - purge the entries

 +28       SET DIK=^DIC(IBF,0,"GL")

           SET IBCNT=0

           SET IBRCNO=""

           FOR 

               SET IBRCNO=$ORDER(^TMP($JOB,"IBPP",IBRCNO))

               IF IBRCNO=""

                   QUIT 

               SET (DA,IBN)=-IBRCNO

               SET IBCNT=IBCNT+1

               IF IBF=399

                   DO NEWV

               DO ^DIK

 +29       KILL ^TMP($JOB,"IBPP")

 +30       IF 'IBCNT

               SET $PIECE(IBD(IBF),"^",4)="No Entries Purged"

               DO DEL^IBPU1(IBF)

               DO UPD^IBPU1(IBLOG,.05,"/3")

               GOTO END

 +31      ; update log entry with count

           DO UPD^IBPU1(IBLOG,.04,IBCNT)

 +32      ; set end time of purge in log

           DO UPD^IBPU1(IBLOG,3.02,"NOW")

 +33      ; close out log entry

           DO UPD^IBPU1(IBLOG,.05,"/2")

 +34      ; delete search template

           DO DEL^IBPU1(IBF)

END        QUIT 

NEWV      ;

 +1        NEW DA,DIE,DIK

 +2        DO ^IBPU2

 +3        QUIT