IBCEMPRG ;ALB/JEH - Purge Status Messages ;25-apr-01
;;2.0;INTEGRATED BILLING;**137**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;This routine will run as part of the EDI nightly background job.
;It will purge status messages in a Final Reveiw Status from
;file 361. If the field, Days to Wait to Purge Msgs(#8.02),
;of the IB Site Parameters file (#350.9) has been populated,
;status messages with a final review date prior to the # days to wait
;to purge msgs will be deleted.
;
EN ; -- main entry point for purging status messages in final review status
N IBDAYS,IBDT,IBDELDT,DIK,DA,X
S IBDAYS=$P($G(^IBE(350.9,1,8)),U,2)
Q:'IBDAYS
S X1=DT,X2=-IBDAYS D C^%DTC S IBDELDT=X
S DIK="^IBM(361,"
S IBDT=0 F S IBDT=$O(^IBM(361,"AFR",IBDT)) Q:'IBDT!(IBDT>IBDELDT) S DA=0 F S DA=$O(^IBM(361,"AFR",IBDT,DA)) Q:'DA D ^DIK
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMPRG 894 printed Oct 16, 2024@18:11:35 Page 2
IBCEMPRG ;ALB/JEH - Purge Status Messages ;25-apr-01
+1 ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;This routine will run as part of the EDI nightly background job.
+4 ;It will purge status messages in a Final Reveiw Status from
+5 ;file 361. If the field, Days to Wait to Purge Msgs(#8.02),
+6 ;of the IB Site Parameters file (#350.9) has been populated,
+7 ;status messages with a final review date prior to the # days to wait
+8 ;to purge msgs will be deleted.
+9 ;
EN ; -- main entry point for purging status messages in final review status
+1 NEW IBDAYS,IBDT,IBDELDT,DIK,DA,X
+2 SET IBDAYS=$PIECE($GET(^IBE(350.9,1,8)),U,2)
+3 if 'IBDAYS
QUIT
+4 SET X1=DT
SET X2=-IBDAYS
DO C^%DTC
SET IBDELDT=X
+5 SET DIK="^IBM(361,"
+6 SET IBDT=0
FOR
SET IBDT=$ORDER(^IBM(361,"AFR",IBDT))
if 'IBDT!(IBDT>IBDELDT)
QUIT
SET DA=0
FOR
SET DA=$ORDER(^IBM(361,"AFR",IBDT,DA))
if 'DA
QUIT
DO ^DIK
+7 QUIT
+8 ;
