IBPFU ;ALB/CPM - FIND BILLING DATA TO ARCHIVE - UTILITIES ; 20-APR-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
LAST(NUM) ; Find last valid date for archiving a billing record.
; Input: NUM -- number of previous fiscal years to retain.
; Output: Date of last day of fiscal year which may be archived
N FY S:'$D(NUM) NUM=1
S FY=$S($E(DT,4,5)<10:$E(DT,1,3),1:$E(DT,1,3)+1),FY=FY-(NUM+1)
Q FY_"0930"
;
LOGADD(IBFILE) ; File a log entry in file #350.6
; Input: IBFILE -- File number of file to be archived
; Output: ien of new log entry, or 0 if error occurred.
N DA,DD,DO,DIC,DIE,DR,DLAYGO,IEN,X
S IEN=0 L +^IBE(350.6,0):10 E G LOGADDQ
S X=$P($S($D(^IBE(350.6,0)):^(0),1:"^^-1"),"^",3)+1 I 'X G LOGADDQ
S DIC="^IBE(350.6,",DIC(0)="L",DLAYGO=350.6
F X=X:1 I X>0,'$D(^IBE(350.6,X)) L +^IBE(350.6,X):1 I $T,'$D(^IBE(350.6,X)) S DINUM=X D FILE^DICN I +Y>0 Q
S (DA,IEN)=+Y,DIE="^IBE(350.6,",DR=".02////IB ARCHIVE/PURGE #"_DA_";.03////"_IBFILE_";.05////1;1.01///NOW"
D ^DIE L -^IBE(350.6,IEN) I $D(Y) S IEN=0
LOGADDQ L -^IBE(350.6,0) Q IEN
;
TEMPL(IBFILE,LOGDA) ; Add a new search template to file #.401 (SORT TEMPLATES)
; Input: IBFILE -- File number of file to be archived
; LOGDA -- IEN of log entry
; Output: ien of new template, or 0 if error occurred.
N DA,DD,DO,DIC,DIE,DR,IEN,X
I '$D(IBFILE)!('$D(LOGDA)) S IEN=0 G TEMPLQ
S X="IB ARCHIVE/PURGE #"_LOGDA,DIC(0)="",DIC="^DIBT(" D FILE^DICN
S (DA,IEN)=+Y,DIE=DIC,DR="2////"_DT_";3////"_DUZ(0)_";4////"_IBFILE_";5////"_DUZ_";6////"_DUZ(0)_";8////1"
D ^DIE I $D(Y) S IEN=0
TEMPLQ Q IEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBPFU 1750 printed Dec 13, 2024@02:26:33 Page 2
IBPFU ;ALB/CPM - FIND BILLING DATA TO ARCHIVE - UTILITIES ; 20-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 ;
LAST(NUM) ; Find last valid date for archiving a billing record.
+1 ; Input: NUM -- number of previous fiscal years to retain.
+2 ; Output: Date of last day of fiscal year which may be archived
+3 NEW FY
if '$DATA(NUM)
SET NUM=1
+4 SET FY=$SELECT($EXTRACT(DT,4,5)<10:$EXTRACT(DT,1,3),1:$EXTRACT(DT,1,3)+1)
SET FY=FY-(NUM+1)
+5 QUIT FY_"0930"
+6 ;
LOGADD(IBFILE) ; File a log entry in file #350.6
+1 ; Input: IBFILE -- File number of file to be archived
+2 ; Output: ien of new log entry, or 0 if error occurred.
+3 NEW DA,DD,DO,DIC,DIE,DR,DLAYGO,IEN,X
+4 SET IEN=0
LOCK +^IBE(350.6,0):10
IF '$TEST
GOTO LOGADDQ
+5 SET X=$PIECE($SELECT($DATA(^IBE(350.6,0)):^(0),1:"^^-1"),"^",3)+1
IF 'X
GOTO LOGADDQ
+6 SET DIC="^IBE(350.6,"
SET DIC(0)="L"
SET DLAYGO=350.6
+7 FOR X=X:1
IF X>0
IF '$DATA(^IBE(350.6,X))
LOCK +^IBE(350.6,X):1
IF $TEST
IF '$DATA(^IBE(350.6,X))
SET DINUM=X
DO FILE^DICN
IF +Y>0
QUIT
+8 SET (DA,IEN)=+Y
SET DIE="^IBE(350.6,"
SET DR=".02////IB ARCHIVE/PURGE #"_DA_";.03////"_IBFILE_";.05////1;1.01///NOW"
+9 DO ^DIE
LOCK -^IBE(350.6,IEN)
IF $DATA(Y)
SET IEN=0
LOGADDQ LOCK -^IBE(350.6,0)
QUIT IEN
+1 ;
TEMPL(IBFILE,LOGDA) ; Add a new search template to file #.401 (SORT TEMPLATES)
+1 ; Input: IBFILE -- File number of file to be archived
+2 ; LOGDA -- IEN of log entry
+3 ; Output: ien of new template, or 0 if error occurred.
+4 NEW DA,DD,DO,DIC,DIE,DR,IEN,X
+5 IF '$DATA(IBFILE)!('$DATA(LOGDA))
SET IEN=0
GOTO TEMPLQ
+6 SET X="IB ARCHIVE/PURGE #"_LOGDA
SET DIC(0)=""
SET DIC="^DIBT("
DO FILE^DICN
+7 SET (DA,IEN)=+Y
SET DIE=DIC
SET DR="2////"_DT_";3////"_DUZ(0)_";4////"_IBFILE_";5////"_DUZ_";6////"_DUZ(0)_";8////1"
+8 DO ^DIE
IF $DATA(Y)
SET IEN=0
TEMPLQ QUIT IEN
