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)
Q
;
C1 S IBSEQNO=$O(^IB("APOST",IBNOW,DFN,"")) Q:'IBSEQNO S IBDUZ=$O(^IB("APOST",IBNOW,DFN,IBSEQNO,"")) Q:'IBDUZ D C2
Q
;
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
Q
;
LAST S DIE="^IBE(350.9,",DA=1,DR=".06///NOW" D ^DIE K DIE,DA,DR
Q
;
CHKDT ; -- update dt if not the same
N X,%
D NOW^%DTC
S:X'=DT DT=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBEFCOP 844 printed Oct 16, 2024@18:22:32 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
