IBCECSA7 ;ALB/ESG - VIEW EOB SCREEN CONTINUED ;26-JUN-2003
;;2.0;INTEGRATED BILLING;**135,155**;21-MAR-1994
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q ; Must be called at proper entry points
;
LLVLA ;line level adjustment
Q:'$G(IBSRC) ; no MRA
D MRALLA^IBCECSA5
Q
RDATA ;
I '$G(IBSRC) Q ; no review data for IB/MRA
I $G(IBSRC) Q ; no review data for AR either
N IBRM,IBREC,IBFLG,IBFST
S IB=$$SETSTR^VALM1("REVIEW DATA:","",1,50)
D SET(IB)
D CNTRL^VALM10(VALMCNT,1,12,IORVON,IORVOFF)
S ^TMP("IBCECSD",$J,"X",8)=VALMCNT
S (Y,IBFLG)=0 F S Y=$O(^IBM(361.1,IBCNT,21,Y)) Q:'Y D
. S IBREC=$G(^IBM(361.1,IBCNT,21,Y,0)),IBFLG=1
. D SET(" REVIEW DATE/TIME: "_$$DAT1^IBOUTL($P(IBREC,U),1))
. S Z=0,IBFST=1 F S Z=$O(^IBM(361.1,IBCNT,21,Y,1,Z)) Q:'Z D
.. S IBRM=$G(^IBM(361.1,IBCNT,21,Y,1,Z,0))
.. D:IBFST SET(" COMMENT:"_$E(IBRM,1,68))
.. D TXT^IBCECSA5(IBRM,68,11)
.. S IBFST=0
D:'IBFLG SET(" NONE")
Q
;
ARCP ; A/R corrected payment data from splitting payment in EOB Worklist
N Z,Z0
I '$O(^IBM(361.1,IBCNT,8,0)) Q
S IB=$$SETSTR^VALM1(" **A/R CORRECTED PAYMENT DATA:","",1,50)
D SET(IB)
I '$G(IBSRC) D
. D CNTRL^VALM10(VALMCNT,1,27,IORVON,IORVOFF)
. S ^TMP("IBCECSD",$J,"X",5)=VALMCNT
D SET(" TOTAL AMT PD: "_$J(+$P($G(^IBM(361.1,IBCNT,1)),U,1),"",2))
S Z=0 F S Z=$O(^IBM(361.1,IBCNT,8,Z)) Q:'Z S Z0=$G(^(Z,0)) D
. S IB=$E($J("",6)_$S($P(Z0,U,3):$$BN1^PRCAFN(+$P(Z0,U,3)),1:"[suspense]"_$P(Z0,U))_$J("",25),1,25)_" "_$J(+$P(Z0,U,2),"",2)
. D SET(IB)
Q
;
INSINF(IBREC,CNT,IBCNT) ; Extract insured information (moved from IBCECSA6)
N IB,IBZ,IBSEQ,IBREL,Z,Z0
S IBSEQ=+$$COBN^IBCEF(IBREC)
S IB=$$SETSTR^VALM1("Patient Name: "_$P($G(^DPT(+$P($G(^DGCR(399,IBREC,0)),U,2),0)),U),"",2,39)
D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBREC)
S IBREL=$G(IBZ(IBSEQ))
S IB=$$SETSTR^VALM1("Pt. Relation : "_$$EXTERNAL^DILFD(2.312,16,"",IBREL),IB,41,38)
D SET^IBCECSA6($G(IBSRC),IB,CNT,IBCNT)
S Z=2,Z0=39,IB=""
I +IBREL'=1 D
. D F^IBCEF("N-ALL INSURED FULL NAMES","IBZ",,IBREC)
. S IB=$$SETSTR^VALM1("Insured Name: "_$G(IBZ(IBSEQ)),IB,Z,Z0)
. S Z=41,Z0=38
D F^IBCEF("N-ALL INSURANCE NUMBER","IBZ",,IBREC)
S IB=$$SETSTR^VALM1("Insured ID "_$S(Z=41:" ",1:"")_": "_$G(IBZ(IBSEQ)),IB,Z,Z0)
D SET^IBCECSA6($G(IBSRC),IB,CNT,IBCNT)
Q
;
SET(IB,IBSAV) ;
I '$G(IBSAV) D SET^IBCECSA6($G(IBSRC),IB,CNT,IBCNT)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCECSA7 2455 printed Oct 16, 2024@18:10:32 Page 2
IBCECSA7 ;ALB/ESG - VIEW EOB SCREEN CONTINUED ;26-JUN-2003
+1 ;;2.0;INTEGRATED BILLING;**135,155**;21-MAR-1994
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; Must be called at proper entry points
QUIT
+5 ;
LLVLA ;line level adjustment
+1 ; no MRA
if '$GET(IBSRC)
QUIT
+2 DO MRALLA^IBCECSA5
+3 QUIT
RDATA ;
+1 ; no review data for IB/MRA
IF '$GET(IBSRC)
QUIT
+2 ; no review data for AR either
IF $GET(IBSRC)
QUIT
+3 NEW IBRM,IBREC,IBFLG,IBFST
+4 SET IB=$$SETSTR^VALM1("REVIEW DATA:","",1,50)
+5 DO SET(IB)
+6 DO CNTRL^VALM10(VALMCNT,1,12,IORVON,IORVOFF)
+7 SET ^TMP("IBCECSD",$JOB,"X",8)=VALMCNT
+8 SET (Y,IBFLG)=0
FOR
SET Y=$ORDER(^IBM(361.1,IBCNT,21,Y))
if 'Y
QUIT
Begin DoDot:1
+9 SET IBREC=$GET(^IBM(361.1,IBCNT,21,Y,0))
SET IBFLG=1
+10 DO SET(" REVIEW DATE/TIME: "_$$DAT1^IBOUTL($PIECE(IBREC,U),1))
+11 SET Z=0
SET IBFST=1
FOR
SET Z=$ORDER(^IBM(361.1,IBCNT,21,Y,1,Z))
if 'Z
QUIT
Begin DoDot:2
+12 SET IBRM=$GET(^IBM(361.1,IBCNT,21,Y,1,Z,0))
+13 if IBFST
DO SET(" COMMENT:"_$EXTRACT(IBRM,1,68))
+14 DO TXT^IBCECSA5(IBRM,68,11)
+15 SET IBFST=0
End DoDot:2
End DoDot:1
+16 if 'IBFLG
DO SET(" NONE")
+17 QUIT
+18 ;
ARCP ; A/R corrected payment data from splitting payment in EOB Worklist
+1 NEW Z,Z0
+2 IF '$ORDER(^IBM(361.1,IBCNT,8,0))
QUIT
+3 SET IB=$$SETSTR^VALM1(" **A/R CORRECTED PAYMENT DATA:","",1,50)
+4 DO SET(IB)
+5 IF '$GET(IBSRC)
Begin DoDot:1
+6 DO CNTRL^VALM10(VALMCNT,1,27,IORVON,IORVOFF)
+7 SET ^TMP("IBCECSD",$JOB,"X",5)=VALMCNT
End DoDot:1
+8 DO SET(" TOTAL AMT PD: "_$JUSTIFY(+$PIECE($GET(^IBM(361.1,IBCNT,1)),U,1),"",2))
+9 SET Z=0
FOR
SET Z=$ORDER(^IBM(361.1,IBCNT,8,Z))
if 'Z
QUIT
SET Z0=$GET(^(Z,0))
Begin DoDot:1
+10 SET IB=$EXTRACT($JUSTIFY("",6)_$SELECT($PIECE(Z0,U,3):$$BN1^PRCAFN(+$PIECE(Z0,U,3)),1:"[suspense]"_$PIECE(Z0,U))_$JUSTIFY("",25),1,25)_" "_$JUSTIFY(+$PIECE(Z0,U,2),"",2)
+11 DO SET(IB)
End DoDot:1
+12 QUIT
+13 ;
INSINF(IBREC,CNT,IBCNT) ; Extract insured information (moved from IBCECSA6)
+1 NEW IB,IBZ,IBSEQ,IBREL,Z,Z0
+2 SET IBSEQ=+$$COBN^IBCEF(IBREC)
+3 SET IB=$$SETSTR^VALM1("Patient Name: "_$PIECE($GET(^DPT(+$PIECE($GET(^DGCR(399,IBREC,0)),U,2),0)),U),"",2,39)
+4 DO F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBREC)
+5 SET IBREL=$GET(IBZ(IBSEQ))
+6 SET IB=$$SETSTR^VALM1("Pt. Relation : "_$$EXTERNAL^DILFD(2.312,16,"",IBREL),IB,41,38)
+7 DO SET^IBCECSA6($GET(IBSRC),IB,CNT,IBCNT)
+8 SET Z=2
SET Z0=39
SET IB=""
+9 IF +IBREL'=1
Begin DoDot:1
+10 DO F^IBCEF("N-ALL INSURED FULL NAMES","IBZ",,IBREC)
+11 SET IB=$$SETSTR^VALM1("Insured Name: "_$GET(IBZ(IBSEQ)),IB,Z,Z0)
+12 SET Z=41
SET Z0=38
End DoDot:1
+13 DO F^IBCEF("N-ALL INSURANCE NUMBER","IBZ",,IBREC)
+14 SET IB=$$SETSTR^VALM1("Insured ID "_$SELECT(Z=41:" ",1:"")_": "_$GET(IBZ(IBSEQ)),IB,Z,Z0)
+15 DO SET^IBCECSA6($GET(IBSRC),IB,CNT,IBCNT)
+16 QUIT
+17 ;
SET(IB,IBSAV) ;
+1 IF '$GET(IBSAV)
DO SET^IBCECSA6($GET(IBSRC),IB,CNT,IBCNT)
+2 QUIT
+3 ;
