IBCEMPRG.m

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 ---IBCEMPRG   894     printed  Apr 09, 2024@21:35:45                                                                                                                                                                                                     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       ;