BAREDP8A ; IHS/SD/LSL - POST HIPAA CLAIMS ; 12/01/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**20,24**;OCT 26,2005;Build 69
; split from BAR50P08
; IHS/SD/POT HEAT148388 1/10/2014 ACCEPT REVERSALS FOR TYPE= 1 IF NEG PAYMENT BAR*1.8*24
Q
PAY ;EP ;PULL CLAIM INFO AND POST PYMT (IF ANY)
K BARCR,CLM,DR
K BARREV,BARSCHED ;BAR*1.8*4 SCR56,SCR58
K BARTO,BARFROM ;TPF BAR*1.8*6 SCR119
;D ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01;.05;1.01;.02;.04","CLM(")
;D ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01;.05;1.01;.02;.04;.11;.12;301","CLM(") ;BAR*1.8*4 SCR56,SCR58
D ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01;.05;1.01;.02;.04;.11;.12;301;501;601;602","CLM(") ;BAR*1.8*5 INCLUDE 'POST THIS CLAIM AS TYPE' FIELD
;start old bar*1.8*20 REQ6
;W !!,"Claim: ",CLM(.01)," <> ",CLM(1.01)
;W !?5,"Billed: ",CLM(.05),?25,"Payment: ",CLM(.04)
;end new bar*1.8*20 REQ6
;BAR*1.8*4 SCR56,SCR58
S CLM(.12)=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,12) ;REVERSAL DATE FORM CLAIMS SUBFILE
I $G(CLM(301))="" S CLM(301)=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,3)),U) ;SCHEDULE #/IPAC FROM CLAIMS SUBFILE
;I +$G(CLM(.11))=22 D ;IF E-CLAIM STATUS CODE = REVERSAL old code
I $$ISREV(CLMDA,IMPDA) D ;new code HEAT148388
.S Y=CLM(.12) X ^DD("DD")
.W !?5,"Reversal Date: ",Y
.W !?5,"Treasury Deposit Number/IPAC: ",CLM(301)
.S BARREV=CLM(.12)
.S BARSCHED=CLM(301)
;END BAR*1.8*4
Q:CLM(.04)=0 ;IF E-PYMT 0 DON'T POST
S BARCR=CLM(.04)
S BARTRAN=40
;BAR*1.8*5 TPF 6/17/2008
I CLM(501)'="" D
.S BARTRAN=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,5)),U) ;CLM(501) GIVES EXTERNAL VALUE
I CLM(601)'="" D
S BARTO=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,6)),U)
I CLM(602)'="" D
.S BARFROM=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,6)),U,2)
;END
S DR="2////^S X=BARCR" ;Credit ($)
S DR=DR_";14////^S X=$G(BARCOL)" ;IEN to A/R COLLECTION BATCH
S DR=DR_";15////^S X=$G(BARITM)" ;IEN to ITEM mult in A/R COL
;BAR*1.8*4 SCR56,SCR58
I $G(BARREV) D
.S DR=DR_";110////^S X=$G(BARREV)"
.S DR=DR_";111////^S X=$G(BARSCHED)"
;END BAR*1.8*4
D DR^BAREDP08
S BARDR=DR
K DR
D POSTRAN^BAREDP08
Q
; ******************
ADJMULT ;EP ;POST ADJUSTMENTS
K BARTO,BARFROM ;TPF BAR*1.8*6 SCR119
K ADJ,DR,BARDR
;D ENPM^XBDIQ1(90056.0208,"IMPDA,CLMDA,0",".02;.04;.05","ADJ(","I")
D ENPM^XBDIQ1(90056.0208,"IMPDA,CLMDA,0",".02;.03;.04;.05","ADJ(","I") ;BAR*1.8*1 SRS ADDENDUM
Q:'$D(ADJ)
S BARTRAN=43
S DR="2////^S X=BARCR" ;Credit $$
S DR=DR_";102////^S X=BARCAT"
S DR=DR_";103////^S X=BARREA"
S DR=DR_";109////^S X=BARSTREA" ;BAR*1.8*1 SRS ADDENDUM STND REASON
I +$G(BARCOL)>0 S DR=DR_";14////^S X=$G(BARCOL)" ;Collct btch if know ;bar*1.8*19*ADD*TMM
I +$G(BARITM)>0 S DR=DR_";15////^S X=$G(BARITM)" ;Item if known ;bar*1.8*19*ADD*TMM
D DR^BAREDP08
S BARDR=DR
K DR
S ADJDA=0
F S ADJDA=$O(ADJ(ADJDA)) Q:ADJDA'>0 D
.S BARCR=ADJ(ADJDA,.02,"I")
.S BARSTREA=ADJ(ADJDA,.03,"I") ;BAR*1.8*1 SRS ADDENDUM GRAB STANDARD CLAIM ADJ REASON
.S BARCAT=ADJ(ADJDA,.04,"I")
.S BARREA=ADJ(ADJDA,.05,"I")
.D POSTRAN^BAREDP08
.K ADJP
.;D ENP^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA",".02;.04;.05","ADJP(")
.D ENP^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA",".02;.03;.04;.05","ADJP(") ;BAR*1.8*1 SRS ADDENDUM
.;start old bar*1.8*20 REQ6
.;W !?5,"ADJ: ",ADJP(.02),?25,ADJP(.04),?45,ADJP(.05)
.;W !?5,"STND REAS: ",ADJP(.03) ;BAR*1.8*1 SRS ADDENDUM
.;end old start new REQ6
.W !?7,"ADJ: ",ADJP(.02),?25,ADJP(.04),?45,ADJP(.05)
.W !?7,"STND REAS: ",ADJP(.03)
.;end new REQ6
Q
RMKCD ; POST REMARK CODES
K BARTO,BARFROM ;TPF BAR*1.8*6 SCR119
K RMK,DR,BARDR
D ENPM^XBDIQ1(90056.0211,"IMPDA,CLMDA,0",".03","RMK(","I")
Q:'$D(RMK)
S BARTRAN=505
S DR=""
D DR^BAREDP08
S DR=$E(DR,2,9999) ;Strip leading ";"
I +$G(BARCOL)>0 S DR=DR_";14////^S X=$G(BARCOL)" ;Collct btch if know
I +$G(BARITM)>0 S DR=DR_";15////^S X=$G(BARITM)" ;Item if known
S DR=DR_";107////^S X=BARMKCD" ;Remark Code ptr
S BARDR=DR
K DR
S RMKDA=0
F S RMKDA=$O(RMK(RMKDA)) Q:'+RMKDA D
.S BARMKCD=RMK(RMKDA,.03,"I")
.Q:BARMKCD=""
.D POSTRAN^BAREDP08
.K RMKP
.D ENP^XBDIQ1(90056.0211,"IMPDA,CLMDA,RMKDA",".02;.03","RMKP(")
.;W !?5,"REMARK CODE: ",RMKP(.03),?25,$E($P(RMKP(.02)," ",3,99),1,50) ;bar*1.8*20 REQ6
.W !?7,"REMARK CODE: ",RMKP(.03),?25,$E($P(RMKP(.02)," ",3,99),1,50) ;bar*1.8*20 REQ6
Q
ISREV(CLMDA,IMPDA) ;P.OTT 1/10/2014 HEAT148388 BAR*1.8*24
I +$$GET1^DIQ(90056.0205,CLMDA_","_IMPDA_",",.11)=22 Q 1
Q 0
;----------------
BAREDP8A ; IHS/SD/LSL - POST HIPAA CLAIMS ; 12/01/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**20,24**;OCT 26,2005;Build 69
+2 ; split from BAR50P08
+3 ; IHS/SD/POT HEAT148388 1/10/2014 ACCEPT REVERSALS FOR TYPE= 1 IF NEG PAYMENT BAR*1.8*24
+4 QUIT
PAY ;EP ;PULL CLAIM INFO AND POST PYMT (IF ANY)
+1 KILL BARCR,CLM,DR
+2 ;BAR*1.8*4 SCR56,SCR58
KILL BARREV,BARSCHED
+3 ;TPF BAR*1.8*6 SCR119
KILL BARTO,BARFROM
+4 ;D ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01;.05;1.01;.02;.04","CLM(")
+5 ;D ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01;.05;1.01;.02;.04;.11;.12;301","CLM(") ;BAR*1.8*4 SCR56,SCR58
+6 ;BAR*1.8*5 INCLUDE 'POST THIS CLAIM AS TYPE' FIELD
DO ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01;.05;1.01;.02;.04;.11;.12;301;501;601;602","CLM(")
+7 ;start old bar*1.8*20 REQ6
+8 ;W !!,"Claim: ",CLM(.01)," <> ",CLM(1.01)
+9 ;W !?5,"Billed: ",CLM(.05),?25,"Payment: ",CLM(.04)
+10 ;end new bar*1.8*20 REQ6
+11 ;BAR*1.8*4 SCR56,SCR58
+12 ;REVERSAL DATE FORM CLAIMS SUBFILE
SET CLM(.12)=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,12)
+13 ;SCHEDULE #/IPAC FROM CLAIMS SUBFILE
IF $GET(CLM(301))=""
SET CLM(301)=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,3)),U)
+14 ;I +$G(CLM(.11))=22 D ;IF E-CLAIM STATUS CODE = REVERSAL old code
+15 ;new code HEAT148388
IF $$ISREV(CLMDA,IMPDA)
Begin DoDot:1
+16 SET Y=CLM(.12)
XECUTE ^DD("DD")
+17 WRITE !?5,"Reversal Date: ",Y
+18 WRITE !?5,"Treasury Deposit Number/IPAC: ",CLM(301)
+19 SET BARREV=CLM(.12)
+20 SET BARSCHED=CLM(301)
End DoDot:1
+21 ;END BAR*1.8*4
+22 ;IF E-PYMT 0 DON'T POST
IF CLM(.04)=0
QUIT
+23 SET BARCR=CLM(.04)
+24 SET BARTRAN=40
+25 ;BAR*1.8*5 TPF 6/17/2008
+26 IF CLM(501)'=""
Begin DoDot:1
+27 ;CLM(501) GIVES EXTERNAL VALUE
SET BARTRAN=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,5)),U)
End DoDot:1
+28 IF CLM(601)'=""
Begin DoDot:1
End DoDot:1
+29 SET BARTO=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,6)),U)
+30 IF CLM(602)'=""
Begin DoDot:1
+31 SET BARFROM=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,6)),U,2)
End DoDot:1
+32 ;END
+33 ;Credit ($)
SET DR="2////^S X=BARCR"
+34 ;IEN to A/R COLLECTION BATCH
SET DR=DR_";14////^S X=$G(BARCOL)"
+35 ;IEN to ITEM mult in A/R COL
SET DR=DR_";15////^S X=$G(BARITM)"
+36 ;BAR*1.8*4 SCR56,SCR58
+37 IF $GET(BARREV)
Begin DoDot:1
+38 SET DR=DR_";110////^S X=$G(BARREV)"
+39 SET DR=DR_";111////^S X=$G(BARSCHED)"
End DoDot:1
+40 ;END BAR*1.8*4
+41 DO DR^BAREDP08
+42 SET BARDR=DR
+43 KILL DR
+44 DO POSTRAN^BAREDP08
+45 QUIT
+46 ; ******************
ADJMULT ;EP ;POST ADJUSTMENTS
+1 ;TPF BAR*1.8*6 SCR119
KILL BARTO,BARFROM
+2 KILL ADJ,DR,BARDR
+3 ;D ENPM^XBDIQ1(90056.0208,"IMPDA,CLMDA,0",".02;.04;.05","ADJ(","I")
+4 ;BAR*1.8*1 SRS ADDENDUM
DO ENPM^XBDIQ1(90056.0208,"IMPDA,CLMDA,0",".02;.03;.04;.05","ADJ(","I")
+5 IF '$DATA(ADJ)
QUIT
+6 SET BARTRAN=43
+7 ;Credit $$
SET DR="2////^S X=BARCR"
+8 SET DR=DR_";102////^S X=BARCAT"
+9 SET DR=DR_";103////^S X=BARREA"
+10 ;BAR*1.8*1 SRS ADDENDUM STND REASON
SET DR=DR_";109////^S X=BARSTREA"
+11 ;Collct btch if know ;bar*1.8*19*ADD*TMM
IF +$GET(BARCOL)>0
SET DR=DR_";14////^S X=$G(BARCOL)"
+12 ;Item if known ;bar*1.8*19*ADD*TMM
IF +$GET(BARITM)>0
SET DR=DR_";15////^S X=$G(BARITM)"
+13 DO DR^BAREDP08
+14 SET BARDR=DR
+15 KILL DR
+16 SET ADJDA=0
+17 FOR
SET ADJDA=$ORDER(ADJ(ADJDA))
IF ADJDA'>0
QUIT
Begin DoDot:1
+18 SET BARCR=ADJ(ADJDA,.02,"I")
+19 ;BAR*1.8*1 SRS ADDENDUM GRAB STANDARD CLAIM ADJ REASON
SET BARSTREA=ADJ(ADJDA,.03,"I")
+20 SET BARCAT=ADJ(ADJDA,.04,"I")
+21 SET BARREA=ADJ(ADJDA,.05,"I")
+22 DO POSTRAN^BAREDP08
+23 KILL ADJP
+24 ;D ENP^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA",".02;.04;.05","ADJP(")
+25 ;BAR*1.8*1 SRS ADDENDUM
DO ENP^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA",".02;.03;.04;.05","ADJP(")
+26 ;start old bar*1.8*20 REQ6
+27 ;W !?5,"ADJ: ",ADJP(.02),?25,ADJP(.04),?45,ADJP(.05)
+28 ;W !?5,"STND REAS: ",ADJP(.03) ;BAR*1.8*1 SRS ADDENDUM
+29 ;end old start new REQ6
+30 WRITE !?7,"ADJ: ",ADJP(.02),?25,ADJP(.04),?45,ADJP(.05)
+31 WRITE !?7,"STND REAS: ",ADJP(.03)
+32 ;end new REQ6
End DoDot:1
+33 QUIT
RMKCD ; POST REMARK CODES
+1 ;TPF BAR*1.8*6 SCR119
KILL BARTO,BARFROM
+2 KILL RMK,DR,BARDR
+3 DO ENPM^XBDIQ1(90056.0211,"IMPDA,CLMDA,0",".03","RMK(","I")
+4 IF '$DATA(RMK)
QUIT
+5 SET BARTRAN=505
+6 SET DR=""
+7 DO DR^BAREDP08
+8 ;Strip leading ";"
SET DR=$EXTRACT(DR,2,9999)
+9 ;Collct btch if know
IF +$GET(BARCOL)>0
SET DR=DR_";14////^S X=$G(BARCOL)"
+10 ;Item if known
IF +$GET(BARITM)>0
SET DR=DR_";15////^S X=$G(BARITM)"
+11 ;Remark Code ptr
SET DR=DR_";107////^S X=BARMKCD"
+12 SET BARDR=DR
+13 KILL DR
+14 SET RMKDA=0
+15 FOR
SET RMKDA=$ORDER(RMK(RMKDA))
IF '+RMKDA
QUIT
Begin DoDot:1
+16 SET BARMKCD=RMK(RMKDA,.03,"I")
+17 IF BARMKCD=""
QUIT
+18 DO POSTRAN^BAREDP08
+19 KILL RMKP
+20 DO ENP^XBDIQ1(90056.0211,"IMPDA,CLMDA,RMKDA",".02;.03","RMKP(")
+21 ;W !?5,"REMARK CODE: ",RMKP(.03),?25,$E($P(RMKP(.02)," ",3,99),1,50) ;bar*1.8*20 REQ6
+22 ;bar*1.8*20 REQ6
WRITE !?7,"REMARK CODE: ",RMKP(.03),?25,$EXTRACT($PIECE(RMKP(.02)," ",3,99),1,50)
End DoDot:1
+23 QUIT
ISREV(CLMDA,IMPDA) ;P.OTT 1/10/2014 HEAT148388 BAR*1.8*24
+1 IF +$$GET1^DIQ(90056.0205,CLMDA_","_IMPDA_",",.11)=22
QUIT 1
+2 QUIT 0
+3 ;----------------
