- IBECEA0 ;ALB/CPM - Cancel/Edit/Add... Build List ; 22-APR-93
- ;;2.0;INTEGRATED BILLING;**167,563,651,669**;21-MAR-94;Build 20
- ;;Per VA Directive 6402, 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)
- ..; if ouptatient charge and clinic stop, show it
- ..I $E(IBATYP,1,3)="OPT",$P(IBND,"^",20) S IBATYP=$E(IBATYP_" ",1,17)_" "_$P($G(^IBE(352.5,+$P(IBND,"^",20),0)),"^")
- ..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 IBN,IBDT,IBZ
- ;IB*2.0*669 - protected against a NULL Action Type, restructured For Loop per SAC
- S IBN=0
- F S IBN=$O(^IB("C",DFN,IBN)) Q:'IBN D
- . S IBZ=$G(^IB(IBN,0)),IBAT=$P(IBZ,"^",3)
- . Q:IBAT=""
- . I $P(^IBE(350.1,$P(IBZ,"^",3),0),U)["RX" D
- . . S IBDT=$S($P(IBZ,"^",14):$P(IBZ,"^",14),1:$P($G(^IB(IBN,1)),"^",2))\1
- . . I IBDT,IBDT'<IBABEG,IBDT'>IBAEND S ^TMP("IBECEA",$J,IBDT\1,IBN)=""
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECEA0 3251 printed Jan 18, 2025@03:22:23 Page 2
- IBECEA0 ;ALB/CPM - Cancel/Edit/Add... Build List ; 22-APR-93
- +1 ;;2.0;INTEGRATED BILLING;**167,563,651,669**;21-MAR-94;Build 20
- +2 ;;Per VA Directive 6402, 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 ; if ouptatient charge and clinic stop, show it
- +11 IF $EXTRACT(IBATYP,1,3)="OPT"
- IF $PIECE(IBND,"^",20)
- SET IBATYP=$EXTRACT(IBATYP_" ",1,17)_" "_$PIECE($GET(^IBE(352.5,+$PIECE(IBND,"^",20),0)),"^")
- +12 SET IBCHG=$SELECT(IBATYP["CANCEL":"(",1:" ")_"$"_$PIECE(IBND,"^",7)_$SELECT(IBATYP["CANCEL":")",1:"")
- +13 SET IBAX=$$SETSTR^VALM1(VALMCNT,"",+$PIECE(VALMDDF("CHG#"),"^",2),+$PIECE(VALMDDF("CHG#"),"^",3))
- +14 SET IBAX=$$SETSTR^VALM1($$DAT1^IBOUTL(IBD),IBAX,+$PIECE(VALMDDF("FDATE"),"^",2),+$PIECE(VALMDDF("FDATE"),"^",3))
- +15 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))
- +16 SET IBAX=$$SETSTR^VALM1(IBATYP,IBAX,+$PIECE(VALMDDF("ENTRY"),"^",2),+$PIECE(VALMDDF("ENTRY"),"^",3))
- +17 SET IBAX=$$SETSTR^VALM1($PIECE($PIECE(IBND,"^",11),"-",2),IBAX,+$PIECE(VALMDDF("BILL#"),"^",2),+$PIECE(VALMDDF("BILL#"),"^",3))
- +18 SET IBAX=$$SETSTR^VALM1(IBSTAT,IBAX,+$PIECE(VALMDDF("STATUS"),"^",2),+$PIECE(VALMDDF("STATUS"),"^",3))
- +19 SET IBAX=$$SETSTR^VALM1(IBCHG,IBAX,+$PIECE(VALMDDF("CHARGE"),"^",2),+$PIECE(VALMDDF("CHARGE"),"^",3))
- +20 SET @IBACMAR@(VALMCNT,0)=IBAX
- SET @IBACMAR@("IDX",VALMCNT,VALMCNT)=""
- SET @VALMIDX@(VALMCNT)=VALMCNT
- +21 SET @IBACMIDX@(VALMCNT)=VALMCNT_"^"_DFN_"^"_IBATYP_"^"_IBN_"^"_IBCHG_"^"_IBSTAT
- End DoDot:2
- End DoDot:1
- +22 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
- +23 QUIT
- +24 ;
- 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 IBN,IBDT,IBZ
- +2 ;IB*2.0*669 - protected against a NULL Action Type, restructured For Loop per SAC
- +3 SET IBN=0
- +4 FOR
- SET IBN=$ORDER(^IB("C",DFN,IBN))
- if 'IBN
- QUIT
- Begin DoDot:1
- +5 SET IBZ=$GET(^IB(IBN,0))
- SET IBAT=$PIECE(IBZ,"^",3)
- +6 if IBAT=""
- QUIT
- +7 IF $PIECE(^IBE(350.1,$PIECE(IBZ,"^",3),0),U)["RX"
- Begin DoDot:2
- +8 SET IBDT=$SELECT($PIECE(IBZ,"^",14):$PIECE(IBZ,"^",14),1:$PIECE($GET(^IB(IBN,1)),"^",2))\1
- +9 IF IBDT
- IF IBDT'<IBABEG
- IF IBDT'>IBAEND
- SET ^TMP("IBECEA",$JOB,IBDT\1,IBN)=""
- End DoDot:2
- End DoDot:1