Routine: IBEFCOP

IBEFCOP ;ALB/AAS - INTEGRATED BILLING BACKGROUND FILER FOR RX COPAY ;26-FEB-91

 ;;2.0;INTEGRATED BILLING;**150**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

COPAY ;  - find pharmacy copay entries to process

 S IBHT=1

 S IBNOW="" F  S IBNOW=$O(^IB("APOST",IBNOW)) Q:'IBNOW  L +^IB("APOST",IBNOW):0 I $T S DFN=$O(^IB("APOST",IBNOW,"")) Q:'DFN  D C1 L -^IB("APOST",IBNOW)

C1 S IBSEQNO=$O(^IB("APOST",IBNOW,DFN,"")) Q:'IBSEQNO  S IBDUZ=$O(^IB("APOST",IBNOW,DFN,IBSEQNO,"")) Q:'IBDUZ  D C2

C2 D CHKDT S IBNOS=^IB("APOST",IBNOW,DFN,IBSEQNO,IBDUZ) K ^IB("APOST",IBNOW,DFN,IBSEQNO,IBDUZ) D FILER^IBARXMA(+IBNOS),^IBR

 D LAST

LAST S DIE="^IBE(350.9,",DA=1,DR=".06///NOW" D ^DIE K DIE,DA,DR

CHKDT ; -- update dt if not the same

 N X,%

 D NOW^%DTC

 S:X'=DT DT=X

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBEFCOP   844     printed  Apr 09, 2024@21:34:38                                                                                                                                                                                                      Page 2

IBEFCOP   ;ALB/AAS - INTEGRATED BILLING BACKGROUND FILER FOR RX COPAY ;26-FEB-91

 +1       ;;2.0;INTEGRATED BILLING;**150**;21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

COPAY     ;  - find pharmacy copay entries to process

 +1       ;

 +2        SET IBHT=1

 +3        SET IBNOW=""

FOR

               SET IBNOW=$ORDER(^IB("APOST",IBNOW))

               if 'IBNOW

                   QUIT

               LOCK +^IB("APOST",IBNOW):0

               IF $TEST

                   SET DFN=$ORDER(^IB("APOST",IBNOW,""))

                   if 'DFN

                       QUIT

                   DO C1

                   LOCK -^IB("APOST",IBNOW)

 +4        QUIT

 +5       ;

C1         SET IBSEQNO=$ORDER(^IB("APOST",IBNOW,DFN,""))

           if 'IBSEQNO

               QUIT

           SET IBDUZ=$ORDER(^IB("APOST",IBNOW,DFN,IBSEQNO,""))

           if 'IBDUZ

               QUIT

           DO C2

 +1        QUIT

 +2       ;

C2         DO CHKDT

           SET IBNOS=^IB("APOST",IBNOW,DFN,IBSEQNO,IBDUZ)

           KILL ^IB("APOST",IBNOW,DFN,IBSEQNO,IBDUZ)

           DO FILER^IBARXMA(+IBNOS)

           DO ^IBR

 +1        DO LAST

 +2        QUIT

 +3       ;

LAST       SET DIE="^IBE(350.9,"

           SET DA=1

           SET DR=".06///NOW"

           DO ^DIE

           KILL DIE,DA,DR

 +1        QUIT

 +2       ;

CHKDT     ; -- update dt if not the same

 +1        NEW X,%

 +2        DO NOW^%DTC

 +3        if X'=DT

               SET DT=X

 +4        QUIT

IBEFCOP.m