IBECEA0 ;ALB/CPM - Cancel/Edit/Add... Build List ; 22-APR-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
ARRAY ; Build list for the List Manager.
N C,IBATYP,IBAX,IBCHG,IBD,IBN,IBND,IBSTAT,Y
S VALMBG=1,VALMCNT=0,VALMBCK="R"
K @IBACMAR,@IBACMIDX,@VALMIDX,^TMP("IBACM",$J),^TMP("IBECEA",$J)
D APDT,APTDT:$G(IBRX)
S IBD="" F S IBD=$O(^TMP("IBECEA",$J,IBD)) Q:'IBD D
.S IBN="" F S IBN=$O(^TMP("IBECEA",$J,IBD,IBN)) Q:'IBN D
..S IBND=^IB(IBN,0) Q:$P(IBND,"^",7)=""
..S VALMCNT=VALMCNT+1,Y=$P(IBND,"^",5),C=$P(^DD(350,.05,0),"^",2) D Y^DIQ S IBSTAT=Y
..S IBATYP=$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^") S:$E(IBATYP,1,2)="DG" IBATYP=$E(IBATYP,4,99)
..S IBCHG=$S(IBATYP["CANCEL":"(",1:" ")_"$"_$P(IBND,"^",7)_$S(IBATYP["CANCEL":")",1:"")
..S IBAX=$$SETSTR^VALM1(VALMCNT,"",+$P(VALMDDF("CHG#"),"^",2),+$P(VALMDDF("CHG#"),"^",3))
..S IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL(IBD),IBAX,+$P(VALMDDF("FDATE"),"^",2),+$P(VALMDDF("FDATE"),"^",3))
..S IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL($S($P(IBND,"^",8)["RX COPAY":IBD,1:$P(IBND,"^",15))),IBAX,+$P(VALMDDF("TDATE"),"^",2),+$P(VALMDDF("TDATE"),"^",3))
..S IBAX=$$SETSTR^VALM1(IBATYP,IBAX,+$P(VALMDDF("ENTRY"),"^",2),+$P(VALMDDF("ENTRY"),"^",3))
..S IBAX=$$SETSTR^VALM1($P($P(IBND,"^",11),"-",2),IBAX,+$P(VALMDDF("BILL#"),"^",2),+$P(VALMDDF("BILL#"),"^",3))
..S IBAX=$$SETSTR^VALM1(IBSTAT,IBAX,+$P(VALMDDF("STATUS"),"^",2),+$P(VALMDDF("STATUS"),"^",3))
..S IBAX=$$SETSTR^VALM1(IBCHG,IBAX,+$P(VALMDDF("CHARGE"),"^",2),+$P(VALMDDF("CHARGE"),"^",3))
..S @IBACMAR@(VALMCNT,0)=IBAX,@IBACMAR@("IDX",VALMCNT,VALMCNT)="",@VALMIDX@(VALMCNT)=VALMCNT
..S @IBACMIDX@(VALMCNT)=VALMCNT_"^"_DFN_"^"_IBATYP_"^"_IBN_"^"_IBCHG_"^"_IBSTAT
I '$O(@IBACMAR@(0)) S @IBACMAR@(1,0)=" ",@IBACMAR@(2,0)="No charges meet criteria",VALMCNT=2,@VALMIDX@(1)=1,@VALMIDX@(2)=2
Q
;
APDT ; Gather Means Test and CHAMPVA charges.
N IBN,IBX,Y,Y1
S Y="" F S Y=$O(^IB("AFDT",DFN,Y)) Q:'Y I -Y'>IBAEND S Y1=0 F S Y1=$O(^IB("AFDT",DFN,Y,Y1)) Q:'Y1 D
.S IBN=0 F S IBN=$O(^IB("AF",Y1,IBN)) Q:'IBN D
..Q:'$D(^IB(IBN,0)) S IBX=^(0)
..Q:$P(IBX,"^",8)["ADMISSION"
..I $P(IBX,"^",15)<IBABEG!($P(IBX,"^",14)>IBAEND) Q
..S ^TMP("IBECEA",$J,+$P(IBX,"^",14),IBN)=""
;
S Y=0 F S Y=$O(^IB("ACVA",DFN,Y)) Q:'Y I Y'>IBAEND S Y1=0 F S Y1=$O(^IB("ACVA",DFN,Y,Y1)) Q:'Y1 D
.S IBN=0 F S IBN=$O(^IB("AD",Y1,IBN)) Q:'IBN D
..Q:'$D(^IB(IBN,0)) S IBX=^(0)
..I $P(IBX,"^",15)<IBABEG!($P(IBX,"^",14)>IBAEND) Q
..S ^TMP("IBECEA",$J,Y,IBN)=""
Q
;
APTDT ; Gather Rx copay charges entered through Cancel/Edit/Add.
N DATE,IBN
S DATE=IBABEG F S DATE=$O(^IB("APTDT",DFN,DATE)) Q:'DATE!(DATE>IBAEND) S IBN="" F S IBN=$O(^IB("APTDT",DFN,DATE,IBN)) Q:'IBN I $P($G(^IB(IBN,0)),"^",8)["RX" S ^TMP("IBECEA",$J,DATE\1,IBN)=""
Q
IBECEA0 ;ALB/CPM - Cancel/Edit/Add... Build List ; 22-APR-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
ARRAY ; Build list for the List Manager.
+1 NEW C,IBATYP,IBAX,IBCHG,IBD,IBN,IBND,IBSTAT,Y
+2 SET VALMBG=1
SET VALMCNT=0
SET VALMBCK="R"
+3 KILL @IBACMAR,@IBACMIDX,@VALMIDX,^TMP("IBACM",$JOB),^TMP("IBECEA",$JOB)
+4 DO APDT
IF $GET(IBRX)
DO APTDT
+5 SET IBD=""
FOR
SET IBD=$ORDER(^TMP("IBECEA",$JOB,IBD))
IF 'IBD
QUIT
Begin DoDot:1
+6 SET IBN=""
FOR
SET IBN=$ORDER(^TMP("IBECEA",$JOB,IBD,IBN))
IF 'IBN
QUIT
Begin DoDot:2
+7 SET IBND=^IB(IBN,0)
IF $PIECE(IBND,"^",7)=""
QUIT
+8 SET VALMCNT=VALMCNT+1
SET Y=$PIECE(IBND,"^",5)
SET C=$PIECE(^DD(350,.05,0),"^",2)
DO Y^DIQ
SET IBSTAT=Y
+9 SET IBATYP=$PIECE($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),"^")
IF $EXTRACT(IBATYP,1,2)="DG"
SET IBATYP=$EXTRACT(IBATYP,4,99)
+10 SET IBCHG=$SELECT(IBATYP["CANCEL":"(",1:" ")_"$"_$PIECE(IBND,"^",7)_$SELECT(IBATYP["CANCEL":")",1:"")
+11 SET IBAX=$$SETSTR^VALM1(VALMCNT,"",+$PIECE(VALMDDF("CHG#"),"^",2),+$PIECE(VALMDDF("CHG#"),"^",3))
+12 SET IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL(IBD),IBAX,+$PIECE(VALMDDF("FDATE"),"^",2),+$PIECE(VALMDDF("FDATE"),"^",3))
+13 SET IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL($SELECT($PIECE(IBND,"^",8)["RX COPAY":IBD,1:$PIECE(IBND,"^",15))),IBAX,+$PIECE(VALMDDF("TDATE"),"^",2),+$PIECE(VALMDDF("TDATE"),"^",3))
+14 SET IBAX=$$SETSTR^VALM1(IBATYP,IBAX,+$PIECE(VALMDDF("ENTRY"),"^",2),+$PIECE(VALMDDF("ENTRY"),"^",3))
+15 SET IBAX=$$SETSTR^VALM1($PIECE($PIECE(IBND,"^",11),"-",2),IBAX,+$PIECE(VALMDDF("BILL#"),"^",2),+$PIECE(VALMDDF("BILL#"),"^",3))
+16 SET IBAX=$$SETSTR^VALM1(IBSTAT,IBAX,+$PIECE(VALMDDF("STATUS"),"^",2),+$PIECE(VALMDDF("STATUS"),"^",3))
+17 SET IBAX=$$SETSTR^VALM1(IBCHG,IBAX,+$PIECE(VALMDDF("CHARGE"),"^",2),+$PIECE(VALMDDF("CHARGE"),"^",3))
+18 SET @IBACMAR@(VALMCNT,0)=IBAX
SET @IBACMAR@("IDX",VALMCNT,VALMCNT)=""
SET @VALMIDX@(VALMCNT)=VALMCNT
+19 SET @IBACMIDX@(VALMCNT)=VALMCNT_"^"_DFN_"^"_IBATYP_"^"_IBN_"^"_IBCHG_"^"_IBSTAT
End DoDot:2
End DoDot:1
+20 IF '$ORDER(@IBACMAR@(0))
SET @IBACMAR@(1,0)=" "
SET @IBACMAR@(2,0)="No charges meet criteria"
SET VALMCNT=2
SET @VALMIDX@(1)=1
SET @VALMIDX@(2)=2
+21 QUIT
+22 ;
APDT ; Gather Means Test and CHAMPVA charges.
+1 NEW IBN,IBX,Y,Y1
+2 SET Y=""
FOR
SET Y=$ORDER(^IB("AFDT",DFN,Y))
IF 'Y
QUIT
IF -Y'>IBAEND
SET Y1=0
FOR
SET Y1=$ORDER(^IB("AFDT",DFN,Y,Y1))
IF 'Y1
QUIT
Begin DoDot:1
+3 SET IBN=0
FOR
SET IBN=$ORDER(^IB("AF",Y1,IBN))
IF 'IBN
QUIT
Begin DoDot:2
+4 IF '$DATA(^IB(IBN,0))
QUIT
SET IBX=^(0)
+5 IF $PIECE(IBX,"^",8)["ADMISSION"
QUIT
+6 IF $PIECE(IBX,"^",15)<IBABEG!($PIECE(IBX,"^",14)>IBAEND)
QUIT
+7 SET ^TMP("IBECEA",$JOB,+$PIECE(IBX,"^",14),IBN)=""
End DoDot:2
End DoDot:1
+8 ;
+9 SET Y=0
FOR
SET Y=$ORDER(^IB("ACVA",DFN,Y))
IF 'Y
QUIT
IF Y'>IBAEND
SET Y1=0
FOR
SET Y1=$ORDER(^IB("ACVA",DFN,Y,Y1))
IF 'Y1
QUIT
Begin DoDot:1
+10 SET IBN=0
FOR
SET IBN=$ORDER(^IB("AD",Y1,IBN))
IF 'IBN
QUIT
Begin DoDot:2
+11 IF '$DATA(^IB(IBN,0))
QUIT
SET IBX=^(0)
+12 IF $PIECE(IBX,"^",15)<IBABEG!($PIECE(IBX,"^",14)>IBAEND)
QUIT
+13 SET ^TMP("IBECEA",$JOB,Y,IBN)=""
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
APTDT ; Gather Rx copay charges entered through Cancel/Edit/Add.
+1 NEW DATE,IBN
+2 SET DATE=IBABEG
FOR
SET DATE=$ORDER(^IB("APTDT",DFN,DATE))
IF 'DATE!(DATE>IBAEND)
QUIT
SET IBN=""
FOR
SET IBN=$ORDER(^IB("APTDT",DFN,DATE,IBN))
IF 'IBN
QUIT
IF $PIECE($GET(^IB(IBN,0)),"^",8)["RX"
SET ^TMP("IBECEA",$JOB,DATE\1,IBN)=""
+3 QUIT
