BAR50P11 ; IHS/SD/LSL - NEW REPORT ERA CLAIMS (2) ;
;;1.8;IHS ACCOUNTS RECEIVABLE;**3,5,20,21,23**;OCT 26, 2005
;
; IHS/SD/LSL - 10/14/03 - V1.7 Patch 4 - HIPAA
; Routine Created
;;REVERTED P.OTT 10/28/2013 DON'T DISPLAY 'REASON NOT POSTABLE' IF MATCHED
; ********************************************************************
;
COMPUTE ;EP
; Compute line tag required by BARDBQUE but all processing
; is done under PRINT so just quit here
Q
; ********************************************************************
;
PRINT ; EP
; PRINT the report (Browse or Print)
S BAR("PG")=0
I (BARTYP="D"!(BARTYP="B")) D DETAIL
I BARTYP="S" D SUMMARY
I $G(BAR("F1"))="" D
. W !,$$CJ^XLFSTR("* * E N D O F R E P O R T * *",IOM)
. D PAZ^BARRUTL
D CLEANUP
Q
; ********************************************************************
;
HD ; EP
D PAZ^BARRUTL
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BAR("F1")=1 Q
; -------------------------------
;
HDB ; EP
S BAR("PG")=BAR("PG")+1
I BAR("PG")>1 S BAR("LVL")=4
D WHD^BARRHD
I BARTYP="S" D
. X BAR("COL")
. W !,BARDASH,!
Q
; ********************************************************************
;
DETAIL ;
; Print report in brief and detail format
D HDB
K BARFLG ;bar*1.8*20
F XI=1:1:$L(BARINDX) S IND=$E(BARINDX,XI) D INDEX Q:$G(BAR("F1"))
I $D(^XTMP("BAR-ERARPT",$J,DUZ(2))) D
.W !!,$$EN^BARVDF("RVN"),$$CJ^XLFSTR(BARZ("W","HDR"),IOM),!
.W $$EN^BARVDF("RVF")
.S CLMDA=0,BARFLG=1,(BARXBLC,BARXBLT,BARXPYT,BARXADJT)=0
.F S CLMDA=$O(^XTMP("BAR-ERARPT",$J,DUZ(2),CLMDA)) Q:CLMDA'>0 D CLAIM Q:$G(BAR("F1"))
.Q:$G(BAR("F1"))
.K ^XTMP("BAR-ERARPT",$J)
.I BARXBLC=0 W !!,$$CJ^XLFSTR("* * * NO DATA TO PRINT * * *",IOM),! Q
.I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
.W !,BARSTAR
.W !,"TOTALS FOR ",BARZ("W")
.W !?2,"AMOUNT BILLED.........."
.W $J($FN(BARXBLC,","),6)," BILLS(S)"
.W " $",$J($FN(BARXBLT,",",2),15)
.W !?2,"PAYMENTS..............."
.W $J($FN(BARXPYC,","),6)," BILLS(S)"
.W " $",$J($FN(BARXPYT,",",2),15)
.W !?2,"ADJUSTMENTS............"
.W $J($FN(BARXADJC,","),6)," BILLS(S)"
.W ?58,"$",$J($FN(BARXADJT,",",2),15)
.W !
;end new code bar*1.8*20
Q
; *********************************************************************
;
INDEX ; EP
I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
W !!,$$EN^BARVDF("RVN"),$$CJ^XLFSTR(BARZ(IND,"HDR"),IOM),!
W $$EN^BARVDF("RVF")
S (BARXPYT,BARXBLT,BARXADJT)=0
S (BARXPYC,BARXBLC,BARXADJC)=0
S BARFIRST=1
S CLMDA=0
F S CLMDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,"AC",IND,CLMDA)) Q:CLMDA'>0 D CLAIM Q:$G(BAR("F1"))
Q:$G(BAR("F1"))
I BARXBLC=0 W !!,$$CJ^XLFSTR("* * * NO DATA TO PRINT * * *",IOM),! Q
I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
W !,BARSTAR
W !,"TOTALS FOR ",BARZ(IND)
W !?2,"AMOUNT BILLED.........."
W $J($FN(BARXBLC,","),6)," BILLS(S)"
W " $",$J($FN(BARXBLT,",",2),15)
W !?2,"PAYMENTS..............."
W $J($FN(BARXPYC,","),6)," BILLS(S)"
W " $",$J($FN(BARXPYT,",",2),15)
W !?2,"ADJUSTMENTS............"
W $J($FN(BARXADJC,","),6)," BILLS(S)"
W ?58,"$",$J($FN(BARXADJT,",",2),15)
W !
I $G(INDSAVE)'="" S IND=INDSAVE K INDSAVE ;bar*1.8*20
Q
; ********************************************************************
;
CLAIM ; EP
; WORK THE CLAIM
K CLM
I $P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)'=BARCHK Q
I '$G(BARFLG),IND="M",$D(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4)) S ^XTMP("BAR-ERARPT",$J,DUZ(2),CLMDA)="" Q ;bar*1.8*20
D ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01:.09","CLM(")
;S BARERRC=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U,4) ;OLD 'CLAIM STATUS #204' ;bar*1.8*20
S BARERRC=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2) ;bar*1.8*20
S BARERRCD=""
I +BARERRC S BARERRCD=$$GET1^DIQ(90056.21,BARERRC,.02) ;ERROR CODE FROM 'A/R EDI EDI ERROR CODES'
; Billed amount totals for this index
I +CLM(.05) D
. S BARXBLC=BARXBLC+1
. S BARXBLT=BARXBLT+CLM(.05)
; Payment amount totals for this index
I +CLM(.04) D
. S BARXPYC=BARXPYC+1
. S BARXPYT=BARXPYT+CLM(.04)
; Write RA patient data
I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
I BARTYP="D",'BARFIRST W !,BARDASH
S BARFIRST=0
I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
W !,$E(CLM(.01),1,18) ;RA bill number
W ?19,$E(CLM(.06),1,29) ;RA patient name
W ?49,CLM(.08) ;RA dos begin
W ?62,"- ",$E($P(CLM(.07)," ",3,999),1,15) ;RA HRN/HIC
I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
I BARERRC'="M",BARERRC'="P" D
.W !,"- ** BILL NOT MATCHED TO RPMS "
N REASDA,REASIENS,REASON
;I (BARERRC'="M"),(BARERRC'="P"),$D(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4)) D ;P.OTT 10/28/2013
I (BARERRC'="P"),$D(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4)) D
.W !?4,"REASON NOT POSTABLE: "
.S REASDA=0
.F S REASDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,REASDA)) Q:'REASDA D
..S REASIENS=REASDA_","_CLMDA_","_IMPDA_","
..S REASON=$$GET1^DIQ(90056.0205401,REASIENS,.01,"I")
..S REASON=$$GET1^DIQ(90056.21,REASON_",",.02,"E")
..W !?6,REASON
K REASDA,REASIENS,REASON
I BARERRC="M" S BARMIEN=CLMDA_","_IMPDA_"," W !,"- Matched: "_$$GET1^DIQ(90056.0205,BARMIEN,"1.01","E")
I BARTYP="D" D Q:$G(BAR("F1"))
. I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
. W !!,"AMOUNT BILLED.............................................$",$J($FN(CLM(.05),",",2),15)
. I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
. W !,"PAYMENT...................................................$",$J($FN(CLM(.04),",",2),15)
D ADJ
Q
; ********************************************************************
;
ADJ ;
; Loop adjustment data on claim
K ADJ
Q:'+$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,0)) ; No adjustments
S BARXADJC=BARXADJC+1
I BARTYP="D" D Q:$G(BAR("F1"))
. I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
. W !,"ADJUSTMENTS"
S ADJDA=0
F S ADJDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA)) Q:'+ADJDA D ADJ2 Q:$G(BAR("F1"))
Q:$G(BAR("F1"))
Q
; ********************************************************************
;
ADJ2 ;
;
Q:'$D(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0))
D ENP^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA,",".01:.05","ADJ(")
S BARADJ(0)=$G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0))
S BARXADJT=BARXADJT+ADJ(.02)
I BARTYP="D" D Q:$G(BAR("F1")) ; If detail, write specifics
. I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
. W !?2,$J($P(ADJ(.01)," "),2) ; Standard adj code
. D PAD
. W ?6,ADJ(.03) ; Standard adj description
. W ?53,"$",$J($FN(ADJ(.02),",",2),10) ; Adj amount
. I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
. W !?6,$J($P(BARADJ(0),U,4),3) ; RPMS Category
. W ?10,$E(ADJ(.04),1,19) ; RPMS Category Description
. W ?30,"/"
. W ?32,$J($P(BARADJ(0),U,5),3) ; RPMS Reason Code
. W ?36,$E(ADJ(.05),1,30) ; RPMS Reason Description
Q
; ********************************************************************
;
PAD ;
; Standard Adj Description must be 47 characters
K L,I,K
S K=$P(ADJ(.03)," ",3,999)
S L=$L(K)
I L>45 S K=$E(K,1,46)
I L<46 D
. F I=L:1:46 S K=K_"."
S ADJ(.03)=K
K L,I,K
Q
; ********************************************************************
;
SUMMARY ;
D SUMDATA
I '$D(BARX) D Q
. D HDB
. W !!!,$$CJ^XLFSTR("* * * NO DATA TO PRINT * * *",IOM)
. D PAZ^BARRUTL
D SUMPRINT
Q
; ********************************************************************
;
SUMDATA ;
;
S BAR("COL")="W !,""CLAIM STATUS"",?26,""BILL COUNT"",?40,""PAYMENTS"",?51,""COPAY/DEDUCT"",?66,""ADJUSTMENTS"""
K BARA
F XI=1:1:$L(BARINDX) S BARX($E(BARINDX,XI))=0
S BARX=0
F XI=1:1:$L(BARINDX) S IND=$E(BARINDX,XI) D SUMDATA2
Q
; ********************************************************************
;
SUMDATA2 ;
;
S CLMDA=0
F S CLMDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,"AC",IND,CLMDA)) Q:CLMDA'>0 D SUMDATA3
Q
; ********************************************************************
;
SUMDATA3 ;
K CLM
Q:'$D(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)) ; No data
I $P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)'=BARCHK Q
D ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01:.09","CLM(")
S $P(BARX(IND),U)=$P($G(BARX(IND)),U)+1 ; Bill count per index
S $P(BARX(IND),U,2)=$P($G(BARX(IND)),U,2)+CLM(.04) ; Payment
S $P(BARX,U)=$P($G(BARX),U)+1 ; Total bill count
S $P(BARX,U,2)=$P($G(BARX),U,2)+CLM(.04) ; Total payments
S ADJDA=0
F S ADJDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA)) Q:'+ADJDA D SUMDATA4
Q
; ********************************************************************
;
SUMDATA4 ;
;
Q:'$D(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)) ; No data
S BARADJ0=$G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0))
I ($P(BARADJ0,U,4)=13!($P(BARADJ0,U,4)=14)) D
. S $P(BARX(IND),U,3)=$P($G(BARX(IND)),U,3)+$P(BARADJ0,U,2)
. S $P(BARX,U,3)=$P($G(BARX),U,3)+$P(BARADJ0,U,2)
E D
. S $P(BARX(IND),U,4)=$P($G(BARX(IND)),U,4)+$P(BARADJ0,U,2)
. S $P(BARX,U,4)=$P($G(BARX),U,4)+$P(BARADJ0,U,2)
;S BARA($P(BARADJ0,U,4))=$G(BARA($P(BARADJ0,U,4)))+$P(BARADJ0,U,2)
I $P(BARADJ0,U,4)'="" S BARA($P(BARADJ0,U,4))=$G(BARA($P(BARADJ0,U,4)))+$P(BARADJ0,U,2) ;BAR*1.8*5 SRS-80 IHS/SD/TPF 4/15/2008 FOUND DURING DEVELOPMENT
S BARA=$G(BARA)+$P(BARADJ0,U,2)
Q
; ********************************************************************
;
SUMPRINT ;
;
D HDB
S IND=""
F S IND=$O(BARX(IND)) Q:IND="" D Q:$G(BAR("F1"))
. I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
. W !,BARZ(IND)
. W ?26,$J($P(BARX(IND),U),6)
. W ?35,$J($FN($P(BARX(IND),U,2),",",2),12)
. W ?50,$J($FN($P(BARX(IND),U,3),",",2),12)
. W ?65,$J($FN($P(BARX(IND),U,4),",",2),12)
I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
W !?26,"------",?35,"------------",?50,"------------",?65,"------------"
I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
W !?3,"GRAND TOTALS"
W ?26,$J($P(BARX,U),6)
W ?35,$J($FN($P(BARX,U,2),",",2),12)
W ?50,$J($FN($P(BARX,U,3),",",2),12)
W ?65,$J($FN($P(BARX,U,4),",",2),12)
I '$D(BARA) W !! Q
; Adjustment summary
I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
W !!?10,"ADJUSTMENT Totals:",!
I $Y>(IOSL-5) D HD Q:$G(BAR("F1")) W !
; List copay AND deduct first
F I=13,14 D Q:$G(BAR("F1"))
. I $D(BARA(I)) D Q:$G(BAR("F1"))
. . W ?15,$$GET1^DIQ(90052.01,I,.01)
. . W ?50,$J($FN(BARA(I),",",2),12)
. . W !
. . K BARA(I)
. . I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
; loop the rest
S I=0
F S I=$O(BARA(I)) Q:'+I D
. W ?15,$$GET1^DIQ(90052.01,I,.01)
. W ?50,$J($FN(BARA(I),",",2),12)
. W !
. I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
W ?50,"============",!
I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
W ?50,$J($FN(BARA,",",2),12),!
Q
; ********************************************************************
;
CLEANUP ;
K IMPDA,CLMDA,ADJDA,TRDA,I,J,K,DA,DR,DIC,DIE,CLM,ADJ
Q
BAR50P11 ; IHS/SD/LSL - NEW REPORT ERA CLAIMS (2) ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,5,20,21,23**;OCT 26, 2005
+2 ;
+3 ; IHS/SD/LSL - 10/14/03 - V1.7 Patch 4 - HIPAA
+4 ; Routine Created
+5 ;;REVERTED P.OTT 10/28/2013 DON'T DISPLAY 'REASON NOT POSTABLE' IF MATCHED
+6 ; ********************************************************************
+7 ;
COMPUTE ;EP
+1 ; Compute line tag required by BARDBQUE but all processing
+2 ; is done under PRINT so just quit here
+3 QUIT
+4 ; ********************************************************************
+5 ;
PRINT ; EP
+1 ; PRINT the report (Browse or Print)
+2 SET BAR("PG")=0
+3 IF (BARTYP="D"!(BARTYP="B"))
DO DETAIL
+4 IF BARTYP="S"
DO SUMMARY
+5 IF $GET(BAR("F1"))=""
Begin DoDot:1
+6 WRITE !,$$CJ^XLFSTR("* * E N D O F R E P O R T * *",IOM)
+7 DO PAZ^BARRUTL
End DoDot:1
+8 DO CLEANUP
+9 QUIT
+10 ; ********************************************************************
+11 ;
HD ; EP
+1 DO PAZ^BARRUTL
+2 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET BAR("F1")=1
QUIT
+3 ; -------------------------------
+4 ;
HDB ; EP
+1 SET BAR("PG")=BAR("PG")+1
+2 IF BAR("PG")>1
SET BAR("LVL")=4
+3 DO WHD^BARRHD
+4 IF BARTYP="S"
Begin DoDot:1
+5 XECUTE BAR("COL")
+6 WRITE !,BARDASH,!
End DoDot:1
+7 QUIT
+8 ; ********************************************************************
+9 ;
DETAIL ;
+1 ; Print report in brief and detail format
+2 DO HDB
+3 ;bar*1.8*20
KILL BARFLG
+4 FOR XI=1:1:$LENGTH(BARINDX)
SET IND=$EXTRACT(BARINDX,XI)
DO INDEX
IF $GET(BAR("F1"))
QUIT
+5 IF $DATA(^XTMP("BAR-ERARPT",$JOB,DUZ(2)))
Begin DoDot:1
+6 WRITE !!,$$EN^BARVDF("RVN"),$$CJ^XLFSTR(BARZ("W","HDR"),IOM),!
+7 WRITE $$EN^BARVDF("RVF")
+8 SET CLMDA=0
SET BARFLG=1
SET (BARXBLC,BARXBLT,BARXPYT,BARXADJT)=0
+9 FOR
SET CLMDA=$ORDER(^XTMP("BAR-ERARPT",$JOB,DUZ(2),CLMDA))
IF CLMDA'>0
QUIT
DO CLAIM
IF $GET(BAR("F1"))
QUIT
+10 IF $GET(BAR("F1"))
QUIT
+11 KILL ^XTMP("BAR-ERARPT",$JOB)
+12 IF BARXBLC=0
WRITE !!,$$CJ^XLFSTR("* * * NO DATA TO PRINT * * *",IOM),!
QUIT
+13 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+14 WRITE !,BARSTAR
+15 WRITE !,"TOTALS FOR ",BARZ("W")
+16 WRITE !?2,"AMOUNT BILLED.........."
+17 WRITE $JUSTIFY($FNUMBER(BARXBLC,","),6)," BILLS(S)"
+18 WRITE " $",$JUSTIFY($FNUMBER(BARXBLT,",",2),15)
+19 WRITE !?2,"PAYMENTS..............."
+20 WRITE $JUSTIFY($FNUMBER(BARXPYC,","),6)," BILLS(S)"
+21 WRITE " $",$JUSTIFY($FNUMBER(BARXPYT,",",2),15)
+22 WRITE !?2,"ADJUSTMENTS............"
+23 WRITE $JUSTIFY($FNUMBER(BARXADJC,","),6)," BILLS(S)"
+24 WRITE ?58,"$",$JUSTIFY($FNUMBER(BARXADJT,",",2),15)
+25 WRITE !
End DoDot:1
+26 ;end new code bar*1.8*20
+27 QUIT
+28 ; *********************************************************************
+29 ;
INDEX ; EP
+1 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+2 WRITE !!,$$EN^BARVDF("RVN"),$$CJ^XLFSTR(BARZ(IND,"HDR"),IOM),!
+3 WRITE $$EN^BARVDF("RVF")
+4 SET (BARXPYT,BARXBLT,BARXADJT)=0
+5 SET (BARXPYC,BARXBLC,BARXADJC)=0
+6 SET BARFIRST=1
+7 SET CLMDA=0
+8 FOR
SET CLMDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,"AC",IND,CLMDA))
IF CLMDA'>0
QUIT
DO CLAIM
IF $GET(BAR("F1"))
QUIT
+9 IF $GET(BAR("F1"))
QUIT
+10 IF BARXBLC=0
WRITE !!,$$CJ^XLFSTR("* * * NO DATA TO PRINT * * *",IOM),!
QUIT
+11 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+12 WRITE !,BARSTAR
+13 WRITE !,"TOTALS FOR ",BARZ(IND)
+14 WRITE !?2,"AMOUNT BILLED.........."
+15 WRITE $JUSTIFY($FNUMBER(BARXBLC,","),6)," BILLS(S)"
+16 WRITE " $",$JUSTIFY($FNUMBER(BARXBLT,",",2),15)
+17 WRITE !?2,"PAYMENTS..............."
+18 WRITE $JUSTIFY($FNUMBER(BARXPYC,","),6)," BILLS(S)"
+19 WRITE " $",$JUSTIFY($FNUMBER(BARXPYT,",",2),15)
+20 WRITE !?2,"ADJUSTMENTS............"
+21 WRITE $JUSTIFY($FNUMBER(BARXADJC,","),6)," BILLS(S)"
+22 WRITE ?58,"$",$JUSTIFY($FNUMBER(BARXADJT,",",2),15)
+23 WRITE !
+24 ;bar*1.8*20
IF $GET(INDSAVE)'=""
SET IND=INDSAVE
KILL INDSAVE
+25 QUIT
+26 ; ********************************************************************
+27 ;
CLAIM ; EP
+1 ; WORK THE CLAIM
+2 KILL CLM
+3 IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)'=BARCHK
QUIT
+4 ;bar*1.8*20
IF '$GET(BARFLG)
IF IND="M"
IF $DATA(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4))
SET ^XTMP("BAR-ERARPT",$JOB,DUZ(2),CLMDA)=""
QUIT
+5 DO ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01:.09","CLM(")
+6 ;S BARERRC=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U,4) ;OLD 'CLAIM STATUS #204' ;bar*1.8*20
+7 ;bar*1.8*20
SET BARERRC=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)
+8 SET BARERRCD=""
+9 ;ERROR CODE FROM 'A/R EDI EDI ERROR CODES'
IF +BARERRC
SET BARERRCD=$$GET1^DIQ(90056.21,BARERRC,.02)
+10 ; Billed amount totals for this index
+11 IF +CLM(.05)
Begin DoDot:1
+12 SET BARXBLC=BARXBLC+1
+13 SET BARXBLT=BARXBLT+CLM(.05)
End DoDot:1
+14 ; Payment amount totals for this index
+15 IF +CLM(.04)
Begin DoDot:1
+16 SET BARXPYC=BARXPYC+1
+17 SET BARXPYT=BARXPYT+CLM(.04)
End DoDot:1
+18 ; Write RA patient data
+19 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+20 IF BARTYP="D"
IF 'BARFIRST
WRITE !,BARDASH
+21 SET BARFIRST=0
+22 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+23 ;RA bill number
WRITE !,$EXTRACT(CLM(.01),1,18)
+24 ;RA patient name
WRITE ?19,$EXTRACT(CLM(.06),1,29)
+25 ;RA dos begin
WRITE ?49,CLM(.08)
+26 ;RA HRN/HIC
WRITE ?62,"- ",$EXTRACT($PIECE(CLM(.07)," ",3,999),1,15)
+27 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+28 IF BARERRC'="M"
IF BARERRC'="P"
Begin DoDot:1
+29 WRITE !,"- ** BILL NOT MATCHED TO RPMS "
End DoDot:1
+30 NEW REASDA,REASIENS,REASON
+31 ;I (BARERRC'="M"),(BARERRC'="P"),$D(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4)) D ;P.OTT 10/28/2013
+32 IF (BARERRC'="P")
IF $DATA(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4))
Begin DoDot:1
+33 WRITE !?4,"REASON NOT POSTABLE: "
+34 SET REASDA=0
+35 FOR
SET REASDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,REASDA))
IF 'REASDA
QUIT
Begin DoDot:2
+36 SET REASIENS=REASDA_","_CLMDA_","_IMPDA_","
+37 SET REASON=$$GET1^DIQ(90056.0205401,REASIENS,.01,"I")
+38 SET REASON=$$GET1^DIQ(90056.21,REASON_",",.02,"E")
+39 WRITE !?6,REASON
End DoDot:2
End DoDot:1
+40 KILL REASDA,REASIENS,REASON
+41 IF BARERRC="M"
SET BARMIEN=CLMDA_","_IMPDA_","
WRITE !,"- Matched: "_$$GET1^DIQ(90056.0205,BARMIEN,"1.01","E")
+42 IF BARTYP="D"
Begin DoDot:1
+43 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+44 WRITE !!,"AMOUNT BILLED.............................................$",$JUSTIFY($FNUMBER(CLM(.05),",",2),15)
+45 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+46 WRITE !,"PAYMENT...................................................$",$JUSTIFY($FNUMBER(CLM(.04),",",2),15)
End DoDot:1
IF $GET(BAR("F1"))
QUIT
+47 DO ADJ
+48 QUIT
+49 ; ********************************************************************
+50 ;
ADJ ;
+1 ; Loop adjustment data on claim
+2 KILL ADJ
+3 ; No adjustments
IF '+$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,0))
QUIT
+4 SET BARXADJC=BARXADJC+1
+5 IF BARTYP="D"
Begin DoDot:1
+6 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+7 WRITE !,"ADJUSTMENTS"
End DoDot:1
IF $GET(BAR("F1"))
QUIT
+8 SET ADJDA=0
+9 FOR
SET ADJDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA))
IF '+ADJDA
QUIT
DO ADJ2
IF $GET(BAR("F1"))
QUIT
+10 IF $GET(BAR("F1"))
QUIT
+11 QUIT
+12 ; ********************************************************************
+13 ;
ADJ2 ;
+1 ;
+2 IF '$DATA(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0))
QUIT
+3 DO ENP^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA,",".01:.05","ADJ(")
+4 SET BARADJ(0)=$GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0))
+5 SET BARXADJT=BARXADJT+ADJ(.02)
+6 ; If detail, write specifics
IF BARTYP="D"
Begin DoDot:1
+7 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+8 ; Standard adj code
WRITE !?2,$JUSTIFY($PIECE(ADJ(.01)," "),2)
+9 DO PAD
+10 ; Standard adj description
WRITE ?6,ADJ(.03)
+11 ; Adj amount
WRITE ?53,"$",$JUSTIFY($FNUMBER(ADJ(.02),",",2),10)
+12 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+13 ; RPMS Category
WRITE !?6,$JUSTIFY($PIECE(BARADJ(0),U,4),3)
+14 ; RPMS Category Description
WRITE ?10,$EXTRACT(ADJ(.04),1,19)
+15 WRITE ?30,"/"
+16 ; RPMS Reason Code
WRITE ?32,$JUSTIFY($PIECE(BARADJ(0),U,5),3)
+17 ; RPMS Reason Description
WRITE ?36,$EXTRACT(ADJ(.05),1,30)
End DoDot:1
IF $GET(BAR("F1"))
QUIT
+18 QUIT
+19 ; ********************************************************************
+20 ;
PAD ;
+1 ; Standard Adj Description must be 47 characters
+2 KILL L,I,K
+3 SET K=$PIECE(ADJ(.03)," ",3,999)
+4 SET L=$LENGTH(K)
+5 IF L>45
SET K=$EXTRACT(K,1,46)
+6 IF L<46
Begin DoDot:1
+7 FOR I=L:1:46
SET K=K_"."
End DoDot:1
+8 SET ADJ(.03)=K
+9 KILL L,I,K
+10 QUIT
+11 ; ********************************************************************
+12 ;
SUMMARY ;
+1 DO SUMDATA
+2 IF '$DATA(BARX)
Begin DoDot:1
+3 DO HDB
+4 WRITE !!!,$$CJ^XLFSTR("* * * NO DATA TO PRINT * * *",IOM)
+5 DO PAZ^BARRUTL
End DoDot:1
QUIT
+6 DO SUMPRINT
+7 QUIT
+8 ; ********************************************************************
+9 ;
SUMDATA ;
+1 ;
+2 SET BAR("COL")="W !,""CLAIM STATUS"",?26,""BILL COUNT"",?40,""PAYMENTS"",?51,""COPAY/DEDUCT"",?66,""ADJUSTMENTS"""
+3 KILL BARA
+4 FOR XI=1:1:$LENGTH(BARINDX)
SET BARX($EXTRACT(BARINDX,XI))=0
+5 SET BARX=0
+6 FOR XI=1:1:$LENGTH(BARINDX)
SET IND=$EXTRACT(BARINDX,XI)
DO SUMDATA2
+7 QUIT
+8 ; ********************************************************************
+9 ;
SUMDATA2 ;
+1 ;
+2 SET CLMDA=0
+3 FOR
SET CLMDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,"AC",IND,CLMDA))
IF CLMDA'>0
QUIT
DO SUMDATA3
+4 QUIT
+5 ; ********************************************************************
+6 ;
SUMDATA3 ;
+1 KILL CLM
+2 ; No data
IF '$DATA(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0))
QUIT
+3 IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)'=BARCHK
QUIT
+4 DO ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01:.09","CLM(")
+5 ; Bill count per index
SET $PIECE(BARX(IND),U)=$PIECE($GET(BARX(IND)),U)+1
+6 ; Payment
SET $PIECE(BARX(IND),U,2)=$PIECE($GET(BARX(IND)),U,2)+CLM(.04)
+7 ; Total bill count
SET $PIECE(BARX,U)=$PIECE($GET(BARX),U)+1
+8 ; Total payments
SET $PIECE(BARX,U,2)=$PIECE($GET(BARX),U,2)+CLM(.04)
+9 SET ADJDA=0
+10 FOR
SET ADJDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA))
IF '+ADJDA
QUIT
DO SUMDATA4
+11 QUIT
+12 ; ********************************************************************
+13 ;
SUMDATA4 ;
+1 ;
+2 ; No data
IF '$DATA(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0))
QUIT
+3 SET BARADJ0=$GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0))
+4 IF ($PIECE(BARADJ0,U,4)=13!($PIECE(BARADJ0,U,4)=14))
Begin DoDot:1
+5 SET $PIECE(BARX(IND),U,3)=$PIECE($GET(BARX(IND)),U,3)+$PIECE(BARADJ0,U,2)
+6 SET $PIECE(BARX,U,3)=$PIECE($GET(BARX),U,3)+$PIECE(BARADJ0,U,2)
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET $PIECE(BARX(IND),U,4)=$PIECE($GET(BARX(IND)),U,4)+$PIECE(BARADJ0,U,2)
+9 SET $PIECE(BARX,U,4)=$PIECE($GET(BARX),U,4)+$PIECE(BARADJ0,U,2)
End DoDot:1
+10 ;S BARA($P(BARADJ0,U,4))=$G(BARA($P(BARADJ0,U,4)))+$P(BARADJ0,U,2)
+11 ;BAR*1.8*5 SRS-80 IHS/SD/TPF 4/15/2008 FOUND DURING DEVELOPMENT
IF $PIECE(BARADJ0,U,4)'=""
SET BARA($PIECE(BARADJ0,U,4))=$GET(BARA($PIECE(BARADJ0,U,4)))+$PIECE(BARADJ0,U,2)
+12 SET BARA=$GET(BARA)+$PIECE(BARADJ0,U,2)
+13 QUIT
+14 ; ********************************************************************
+15 ;
SUMPRINT ;
+1 ;
+2 DO HDB
+3 SET IND=""
+4 FOR
SET IND=$ORDER(BARX(IND))
IF IND=""
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+6 WRITE !,BARZ(IND)
+7 WRITE ?26,$JUSTIFY($PIECE(BARX(IND),U),6)
+8 WRITE ?35,$JUSTIFY($FNUMBER($PIECE(BARX(IND),U,2),",",2),12)
+9 WRITE ?50,$JUSTIFY($FNUMBER($PIECE(BARX(IND),U,3),",",2),12)
+10 WRITE ?65,$JUSTIFY($FNUMBER($PIECE(BARX(IND),U,4),",",2),12)
End DoDot:1
IF $GET(BAR("F1"))
QUIT
+11 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+12 WRITE !?26,"------",?35,"------------",?50,"------------",?65,"------------"
+13 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+14 WRITE !?3,"GRAND TOTALS"
+15 WRITE ?26,$JUSTIFY($PIECE(BARX,U),6)
+16 WRITE ?35,$JUSTIFY($FNUMBER($PIECE(BARX,U,2),",",2),12)
+17 WRITE ?50,$JUSTIFY($FNUMBER($PIECE(BARX,U,3),",",2),12)
+18 WRITE ?65,$JUSTIFY($FNUMBER($PIECE(BARX,U,4),",",2),12)
+19 IF '$DATA(BARA)
WRITE !!
QUIT
+20 ; Adjustment summary
+21 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+22 WRITE !!?10,"ADJUSTMENT Totals:",!
+23 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
WRITE !
+24 ; List copay AND deduct first
+25 FOR I=13,14
Begin DoDot:1
+26 IF $DATA(BARA(I))
Begin DoDot:2
+27 WRITE ?15,$$GET1^DIQ(90052.01,I,.01)
+28 WRITE ?50,$JUSTIFY($FNUMBER(BARA(I),",",2),12)
+29 WRITE !
+30 KILL BARA(I)
+31 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
End DoDot:2
IF $GET(BAR("F1"))
QUIT
End DoDot:1
IF $GET(BAR("F1"))
QUIT
+32 ; loop the rest
+33 SET I=0
+34 FOR
SET I=$ORDER(BARA(I))
IF '+I
QUIT
Begin DoDot:1
+35 WRITE ?15,$$GET1^DIQ(90052.01,I,.01)
+36 WRITE ?50,$JUSTIFY($FNUMBER(BARA(I),",",2),12)
+37 WRITE !
+38 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
End DoDot:1
+39 WRITE ?50,"============",!
+40 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+41 WRITE ?50,$JUSTIFY($FNUMBER(BARA,",",2),12),!
+42 QUIT
+43 ; ********************************************************************
+44 ;
CLEANUP ;
+1 KILL IMPDA,CLMDA,ADJDA,TRDA,I,J,K,DA,DR,DIC,DIE,CLM,ADJ
+2 QUIT
