BAREDP0Z ; IHS/SD/LSL - MATCH REASONS AND CLAIMS ; 01/30/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**10,20,23,24,28**;OCT 26, 2005;Build 92
; NEW ROUTINE TO LOCKOUT REVERSALS AND PLB SEGMENTS; MRS:BAR*1.8*10 D159
; MODIFIED TO LIMIT LOCK OUT TO INDIVIDUAL CHECKS
;IHS/SD/POT HEAT148388 ACCEPT REVERSALS FOR TYPE= 1 IF NEG PAYMENT FIX: 1/24/2014- BAR*1.8*.24
;IHS/SD/POT HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS- BAR*1.8*.24
;IHS/SD/POT check for IHSNEGB moved from top to $$NEGP - BAR*1.8*.24
;IHS/DIT/CPC Fix typo CR9572 BAR*1.8*28
Q
EN(IMPDA) ; EP ; Scan SEGMENTS for PLB, REVERSALS AND NEGATIVE AMOUNTS
N BARFLG
;old code Q:'$$IHS^BARUFUT(DUZ(2)) 0 ;Ignore if NON-IHS facility
;I '$$IHSNEGB^BARUFUT(DUZ(2)) Q 0 ;HEAT147572 line moved to $$NEGP 4/22/2014
W !!,"Now will look for PLBs, Payment Reversals, and Negative Payments..." ;bar*1.8*20 REQ4
S BARFLG=0
S BARFLG=$$PLB(IMPDA) ;PLB
S BARFLG=0 ;bar*1.8*20 REQ4
S BARFLG=$$REV(IMPDA) ;REVERSALS
S BARFLG=0 ;bar*1.8*20 REQ4
S BARFLG=$$NEGP(IMPDA) ;NEGATIVE AMT PAYMENT
;start new code bar*1.8*20 REQ4
K DIR
S DIR(0)="E"
S DIR("A")="<CR> - Continue"
D ^DIR
K ^XTMP("BAR-BILLS",$J,DUZ(2)),^XTMP("BAR-BMAMT",$J,DUZ(2))
;end new code REQ4
Q BARFLG
;
; **************
PLB(IMPDA) ; EP ;D159-2
W !!,"Looking for PLB Segment... "
S PLBAMT=+$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U,9)
I (PLBAMT=0) W "No PLB Segments found" Q BARFLG ;No PLB
W "PLB SEGMENT FOUND"
I (PLBAMT<0) W !?2,"The PLB amount increases the check amount - no further action will be taken" Q BARFLG
S IENS=BARCKIEN_","_IMPDA
W !?2,"Bills will be marked Not To Post to accommodate amount ",$FN($$GET1^DIQ(90056.02011,IENS,.09),",",2)
S BARFLG=1
D PLBFIND
;end new code REQ4
Q BARFLG
;
REV(IMPDA) ;EP ;D159-1
;W !,"Looking for Payment Reversals " ;bar*1.8*20 REQ4
W !!,"Looking for Payment Reversals... " ;bar*1.8*20 REQ4
N BARCDA,BAR15,BARAMT,CNT,BARVCK,BARSCK
S BARCDA=0
S (BARVCK,BARSCK)=""
S BAR="REV"
S REVAMT=0
S BARCNT=0
K ^XTMP("BAR-REV",$J) ;bar*1.8*28 IHS/DIT/CPC CR9572 was ;K ^XTMP("BAR=REV",$J)
F CNT=1:1 S BARCDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA)) Q:'BARCDA D
. ;W:'(CNT#1000) "." ;bar*1.8*20 REQ4
. ; old code Q:(+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,11)'=22) ;only looking for REVERSALS
. I '$$ISREV(IMPDA,BARCDA) Q ;new code P.OTT 1/10/2014 HEAT148388 1/24/2024 PARAMETER PASSING- BAR*1.8*.24
.Q:($P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,2)),U)'=$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U)) ;not check number I want
.I BARFLG=0 D
..W "PAYMENT REVERSAL FOUND",!?3,"Bills will be marked Not To Post to accommodate "
..W !,?6,"E-Bill#",?27,"E-Pymt",?39,"E-Claim Status Code"
.S BARFLG=1
.S BARCNT=+$G(BARCNT)+1
.S EAMT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
.S EBILL=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U)
.S ESTAT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,11)
.S ^XTMP("BAR-REV",$J,DUZ(2),BARCDA)=EBILL
.W !,BARCNT,?6,EBILL,?27,$FN(EAMT,",",2),?39,ESTAT
.D UP(IMPDA,BARCDA,"REV")
.S REVAMT=+$G(REVAMT)-$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
I BARFLG D REVFIND
I 'BARFLG W "No Payment Reversals found" Q BARFLG ;No Payment Reversals
;end new code REQ4
Q BARFLG
;
NEGP(IMPDA) ;EP ;D159-1
;W !,"Looking for Negative Payments " ;bar*1.8*20 REQ4
I '$$IHSNEGB^BARUFUT(DUZ(2)) Q 0 ;HEAT147572 line moved to $$NEGP 4/22/2014 bar*1.8*24
W !!,"Looking for Negative Payments... " ;bar*1.8*20 REQ4
N BARCDA,BAR300,BARAMT,CNT,BARSTA,BAR302,BARVCK,BARSCK
S BARCDA=0
S BARSCK=""
S BARCNT=0,REVAMT=0 ;bar*1.8*20 REQ4
F CNT=1:1 S BARCDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA)) Q:'BARCDA D
.;W:'(CNT#1000) "." ;bar*1.8*20 REQ4
.S BAR300=$G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0))
.S BAR302=$G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,2))
.S BARVCK=$P(BAR302,U) ;Check number
.S BARSTA=+$P(BAR300,U,11)
.I BARSTA="" S BARSTA=$P(BAR302,U,4)
.Q:(U_"1"_U_"2"_U_"3"_U_"4"_U_"19"_U_"20"_U_"21"_U)'[(U_BARSTA_U) ;Only want PAYMENTS & DENIALS
.Q:($P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,2)),U)'=$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U)) ;not check number I want
.S BARAMT=$P(BAR300,U,4)
.I BARAMT<0 D
..;Q:BARVCK=BARSCK ;Only process once for each check P.OTTIS HEAT148388 - BAR*1.8*.24
..I BARFLG=0 W "NEGATIVE PAYMENT AMOUNT FOUND",!?2,"Bills will be marked Not To Post to accommodate" ;bar*1.8*20 REQ4
..I BARFLG=0 W !,?6,"E-Bill#",?27,"E-Pymt",?39,"E-Claim Status Code" ;bar*1.8*20 REQ4
..S BARFLG=1
..S BARSCK=BARVCK ;Save Negative amount check number
..S BARCNT=+$G(BARCNT)+1
..S EAMT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
..S EBILL=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U)
..S ^XTMP("BAR-REV",$J,DUZ(2),BARCDA)=EBILL
..W !,BARCNT,?6,EBILL,?27,$FN(EAMT,",",2),?39,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,11)
..D UP(IMPDA,BARCDA,"NEGP")
..S REVAMT=+$G(REVAMT)+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
I BARFLG S BAR="NEGP" D REVFIND
I 'BARFLG W "No Negative Payments found " ;bar*1.8*20 REQ4
Q BARFLG
;
LOOP(IMPDA,REASON,VCHK) ;EP; LOOP THROUGH BAREDI("I",IMPDA AND FLAG NOT TO POST
;
N BARCDA,TCHK
S BARCDA=0
F S BARCDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA)) Q:'BARCDA D
.S TCHK=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,2)),U) ;Transaction check #
.Q:TCHK'=VCHK ; Limit it to just the one check
.D UP(IMPDA,BARCDA,REASON)
Q
;
UP(IMPDA,XCLM,REASON) ;EP; UPDATE STATUS
K DIR,DIE,DA,DIC,DR,X
K DIR,DIE,DA,DIC,DR
S DIC("P")=$P(^DD(90056.0205,401,0),U,2)
S DA(2)=IMPDA
S DA(1)=XCLM
S DIC(0)="L"
S DIC="^BAREDI(""I"",DUZ(2),"_DA(2)_",30,"_DA(1)_",4,"
S X=REASON
D ^DIC
Q
;start new code bar*1.8*20 REQ4
PLBFIND ; EP
;first put all bills for check into bill amount order
S CLMDA=0
K ^XTMP("BAR-MBAMT",$J,DUZ(2))
F S CLMDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA)) Q:'CLMDA D
.Q:($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)'=$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U)) ;only my check
.Q:$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)="P" ;already posted
.Q:(("1^2^3^19^20^21^")'[("^"_$P($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)," | ")_"^")) ;not a payment
.S CHKREASN=$$RCHK
.;if ERA claim has already been marked NTP for PLB, lessen PLB amount by that ERA claim amount
.I BARRCHK=1,((CHKREASN)="PLB") D Q
..S PLBAMT=PLBAMT-$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)
..W !?5,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)_" for $"_$J($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),2)_" was marked Not To Post"
.S ^XTMP("BAR-MBAMT",$J,DUZ(2),$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)="" ;E-payment
S BAMT=0,BARDONE=0
I PLBAMT=0!(PLBAMT<0) Q
F S BAMT=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),BAMT)) Q:'BAMT D Q:BARDONE
.Q:(BAMT<PLBAMT) ;bill amount must be = or > than PLB amount
.S CLMDA=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),BAMT,0)) ;get first claim with that amount
.;by here the BAMT should be as much or more than the PLB amount
.D UP(IMPDA,CLMDA,"PLB") ;mark bill Not To Post
.S BARDONE=1
.W !?2,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)_" for $"_$J($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),2)_" was marked Not To Post"
Q:BARDONE ;stop here if a bill was found and marked Not To Post
S BAMT=99999999999
F S BAMT=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),BAMT),-1) Q:'BAMT D Q:BARDONE
.S CLMDA=999999
.F S CLMDA=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),BAMT,CLMDA),-1) Q:'CLMDA D Q:BARDONE
..D UP(IMPDA,CLMDA,"PLB") ;mark bill Not To Post
..S PLBAMT=PLBAMT-BAMT
..I PLBAMT=0!(PLBAMT<0) S BARDONE=1
..W !?5,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)_" for $"_$J($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),2)_" was marked Not To Post"
W !
Q
REVFIND ;EP
;find pymt to "counter" either payment reversal or negative payment and mark it Not To Post
;payment can be either on same bill, or different bill, or over several bills to "cover" amount
S MTCHAMT=$S(REVAMT<0:(REVAMT*-1),1:REVAMT) ;total amount that needs to be written off
D BUILDLST
Q:MTCHAMT<0 ;bills have already been marked Not To Post
;go through list first time looking for amount on same claim
S REVDA=0,BARDONE=0
S EDA=0
F S EDA=$O(^XTMP("BAR-REV",$J,DUZ(2),EDA)) Q:'EDA D
.S EBILL=$G(^XTMP("BAR-REV",$J,DUZ(2),EDA))
.S EAMT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,EDA,0)),U,4)
.I $D(^BAREDI("I",DUZ(2),IMPDA,30,EDA,4))>10 Q ;bar*1.8*26 IHS/SD/SDR HEAT263595 ;bar*1.8*28 IHS/SD/SDR CR8346 HEAT275351
.S EAMT=EAMT*-1
.I $D(^XTMP("BAR-BILLS",$J,DUZ(2),EBILL)) D
..S MDA=0
..F S MDA=$O(^XTMP("BAR-BILLS",$J,DUZ(2),EBILL,MDA)) Q:'MDA D
...S MAMT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,EDA,0)),U,4)
...I EAMT=MAMT D
....S RCLMDA=$O(^XTMP("BAR-BILLS",$J,DUZ(2),EBILL,MDA,0))
....D UP(IMPDA,RCLMDA,$S(BAR="REV":"REV",1:"NEGP"))
....S MTCHAMT=MTCHAMT-MAMT
....W !?6,EBILL,?27,$J(MAMT,",",2),?39,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U,11)
....K ^XTMP("BAR-BILLS",$J,DUZ(2),EBILL,MDA)
I MTCHAMT>0 D
.S MAMT=0
.F S MAMT=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),MAMT)) Q:'MAMT D
..S MDA=0
..F S MDA=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),MAMT,MDA)) Q:'MDA D
...I $D(^BAREDI("I",DUZ(2),IMPDA,30,MDA,4))>10 Q ;bar*1.8*28 IHS/DIT/CPC CR9572
...Q:MTCHAMT'=MAMT
...;S RCLMDA=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),EBILL,MDA,0))
...D UP(IMPDA,MDA,$S(BAR="REV":"REV",1:"NEGP"))
...S MTCHAMT=MTCHAMT-MAMT
...W !?6,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U),?27,$J(MAMT,",",2),?39,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U,11)
I MTCHAMT>0 D Q:((MTCHAMT=0)!(MTCHAMT<0))
.S MAMT=999999999
.F S MAMT=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),MAMT),-1) Q:'MAMT D Q:((MTCHAMT=0)!(MTCHAMT<0))
..S MDA=0
..F S MDA=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),MAMT,MDA)) Q:'MDA D Q:((MTCHAMT=0)!(MTCHAMT<0))
...I $D(^BAREDI("I",DUZ(2),IMPDA,30,MDA,4))>10 Q ;bar*1.8*28 IHS/DIT/CPC CR9572
...D UP(IMPDA,MDA,$S(BAR="REV":"REV",1:"NEGP"))
...S MTCHAMT=MTCHAMT-MAMT
...W !?6,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U),?27,$J(MAMT,",",2),?39,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U,11)
W !
Q
BUILDLST ;EP
S CLMDA=0
K ^XTMP("BAR-MBAMT",$J,DUZ(2)),^XTMP("BAR-BILLS",$J,DUZ(2))
F S CLMDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA)) Q:'CLMDA D
.Q:($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)'=$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U)) ;only my check
.Q:$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="P" ;already posted
.Q:$D(^XTMP("BAR-REV",$J,DUZ(2),CLMDA)) ;bill is reversal
.S CHKREASN=$$RCHK
.;if ERA claim has already been marked NTP for PLB, lessen PLB amount by that ERA claim amount
.I BARRCHK=1,((CHKREASN)=$S(BAR="REV":"REV",1:"NEGP")) D Q
..S MTCHAMT=MTCHAMT-(+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)) ;bar*1.8*28 IHS/DIT/CPC CR9572
..W !?6,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U),?27,$J($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),",",2),?39,$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)
.S ^XTMP("BAR-MBAMT",$J,DUZ(2),+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)="" ;E-payment ;bar*1.8*28 IHS/DIT/CPC CR9572
.S ^XTMP("BAR-BILLS",$J,DUZ(2),$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U),+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)="" ;bills
Q
RCHK(CHKREASN) ;
S BARRCHK=0,CHKREASN=""
Q:'$D(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4)) CHKREASN ;no reasons not to post
S BARNTPR=0
F S BARNTPR=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,BARNTPR)) Q:'BARNTPR D Q:CHKREASN
.I "^PLB^REV^NEGP^"[("^"_$P($G(^BARERR($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,BARNTPR,0)),U),0)),U)_"^") D
..S BARRCHK=1
..S CHKREASN=$P($G(^BARERR($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,BARNTPR,0)),U),0)),U)
Q CHKREASN
;end new code REQ4
ISREV(IMPDA,CLMDA) ;P.OTT 1/10/2014 HEAT148388- BAR*1.8*.24
I +$$GET1^DIQ(90056.0205,CLMDA_","_IMPDA_",",.11)=22 Q 1
Q 0
;----------------
BAREDP0Z ; IHS/SD/LSL - MATCH REASONS AND CLAIMS ; 01/30/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**10,20,23,24,28**;OCT 26, 2005;Build 92
+2 ; NEW ROUTINE TO LOCKOUT REVERSALS AND PLB SEGMENTS; MRS:BAR*1.8*10 D159
+3 ; MODIFIED TO LIMIT LOCK OUT TO INDIVIDUAL CHECKS
+4 ;IHS/SD/POT HEAT148388 ACCEPT REVERSALS FOR TYPE= 1 IF NEG PAYMENT FIX: 1/24/2014- BAR*1.8*.24
+5 ;IHS/SD/POT HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS- BAR*1.8*.24
+6 ;IHS/SD/POT check for IHSNEGB moved from top to $$NEGP - BAR*1.8*.24
+7 ;IHS/DIT/CPC Fix typo CR9572 BAR*1.8*28
+8 QUIT
EN(IMPDA) ; EP ; Scan SEGMENTS for PLB, REVERSALS AND NEGATIVE AMOUNTS
+1 NEW BARFLG
+2 ;old code Q:'$$IHS^BARUFUT(DUZ(2)) 0 ;Ignore if NON-IHS facility
+3 ;I '$$IHSNEGB^BARUFUT(DUZ(2)) Q 0 ;HEAT147572 line moved to $$NEGP 4/22/2014
+4 ;bar*1.8*20 REQ4
WRITE !!,"Now will look for PLBs, Payment Reversals, and Negative Payments..."
+5 SET BARFLG=0
+6 ;PLB
SET BARFLG=$$PLB(IMPDA)
+7 ;bar*1.8*20 REQ4
SET BARFLG=0
+8 ;REVERSALS
SET BARFLG=$$REV(IMPDA)
+9 ;bar*1.8*20 REQ4
SET BARFLG=0
+10 ;NEGATIVE AMT PAYMENT
SET BARFLG=$$NEGP(IMPDA)
+11 ;start new code bar*1.8*20 REQ4
+12 KILL DIR
+13 SET DIR(0)="E"
+14 SET DIR("A")="<CR> - Continue"
+15 DO ^DIR
+16 KILL ^XTMP("BAR-BILLS",$JOB,DUZ(2)),^XTMP("BAR-BMAMT",$JOB,DUZ(2))
+17 ;end new code REQ4
+18 QUIT BARFLG
+19 ;
+20 ; **************
PLB(IMPDA) ; EP ;D159-2
+1 WRITE !!,"Looking for PLB Segment... "
+2 SET PLBAMT=+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U,9)
+3 ;No PLB
IF (PLBAMT=0)
WRITE "No PLB Segments found"
QUIT BARFLG
+4 WRITE "PLB SEGMENT FOUND"
+5 IF (PLBAMT<0)
WRITE !?2,"The PLB amount increases the check amount - no further action will be taken"
QUIT BARFLG
+6 SET IENS=BARCKIEN_","_IMPDA
+7 WRITE !?2,"Bills will be marked Not To Post to accommodate amount ",$FNUMBER($$GET1^DIQ(90056.02011,IENS,.09),",",2)
+8 SET BARFLG=1
+9 DO PLBFIND
+10 ;end new code REQ4
+11 QUIT BARFLG
+12 ;
REV(IMPDA) ;EP ;D159-1
+1 ;W !,"Looking for Payment Reversals " ;bar*1.8*20 REQ4
+2 ;bar*1.8*20 REQ4
WRITE !!,"Looking for Payment Reversals... "
+3 NEW BARCDA,BAR15,BARAMT,CNT,BARVCK,BARSCK
+4 SET BARCDA=0
+5 SET (BARVCK,BARSCK)=""
+6 SET BAR="REV"
+7 SET REVAMT=0
+8 SET BARCNT=0
+9 ;bar*1.8*28 IHS/DIT/CPC CR9572 was ;K ^XTMP("BAR=REV",$J)
KILL ^XTMP("BAR-REV",$JOB)
+10 FOR CNT=1:1
SET BARCDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA))
IF 'BARCDA
QUIT
Begin DoDot:1
+11 ;W:'(CNT#1000) "." ;bar*1.8*20 REQ4
+12 ; old code Q:(+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,11)'=22) ;only looking for REVERSALS
+13 ;new code P.OTT 1/10/2014 HEAT148388 1/24/2024 PARAMETER PASSING- BAR*1.8*.24
IF '$$ISREV(IMPDA,BARCDA)
QUIT
+14 ;not check number I want
IF ($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,2)),U)'=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U))
QUIT
+15 IF BARFLG=0
Begin DoDot:2
+16 WRITE "PAYMENT REVERSAL FOUND",!?3,"Bills will be marked Not To Post to accommodate "
+17 WRITE !,?6,"E-Bill#",?27,"E-Pymt",?39,"E-Claim Status Code"
End DoDot:2
+18 SET BARFLG=1
+19 SET BARCNT=+$GET(BARCNT)+1
+20 SET EAMT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
+21 SET EBILL=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U)
+22 SET ESTAT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,11)
+23 SET ^XTMP("BAR-REV",$JOB,DUZ(2),BARCDA)=EBILL
+24 WRITE !,BARCNT,?6,EBILL,?27,$FNUMBER(EAMT,",",2),?39,ESTAT
+25 DO UP(IMPDA,BARCDA,"REV")
+26 SET REVAMT=+$GET(REVAMT)-$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
End DoDot:1
+27 IF BARFLG
DO REVFIND
+28 ;No Payment Reversals
IF 'BARFLG
WRITE "No Payment Reversals found"
QUIT BARFLG
+29 ;end new code REQ4
+30 QUIT BARFLG
+31 ;
NEGP(IMPDA) ;EP ;D159-1
+1 ;W !,"Looking for Negative Payments " ;bar*1.8*20 REQ4
+2 ;HEAT147572 line moved to $$NEGP 4/22/2014 bar*1.8*24
IF '$$IHSNEGB^BARUFUT(DUZ(2))
QUIT 0
+3 ;bar*1.8*20 REQ4
WRITE !!,"Looking for Negative Payments... "
+4 NEW BARCDA,BAR300,BARAMT,CNT,BARSTA,BAR302,BARVCK,BARSCK
+5 SET BARCDA=0
+6 SET BARSCK=""
+7 ;bar*1.8*20 REQ4
SET BARCNT=0
SET REVAMT=0
+8 FOR CNT=1:1
SET BARCDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA))
IF 'BARCDA
QUIT
Begin DoDot:1
+9 ;W:'(CNT#1000) "." ;bar*1.8*20 REQ4
+10 SET BAR300=$GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0))
+11 SET BAR302=$GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,2))
+12 ;Check number
SET BARVCK=$PIECE(BAR302,U)
+13 SET BARSTA=+$PIECE(BAR300,U,11)
+14 IF BARSTA=""
SET BARSTA=$PIECE(BAR302,U,4)
+15 ;Only want PAYMENTS & DENIALS
IF (U_"1"_U_"2"_U_"3"_U_"4"_U_"19"_U_"20"_U_"21"_U)'[(U_BARSTA_U)
QUIT
+16 ;not check number I want
IF ($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,2)),U)'=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U))
QUIT
+17 SET BARAMT=$PIECE(BAR300,U,4)
+18 IF BARAMT<0
Begin DoDot:2
+19 ;Q:BARVCK=BARSCK ;Only process once for each check P.OTTIS HEAT148388 - BAR*1.8*.24
+20 ;bar*1.8*20 REQ4
IF BARFLG=0
WRITE "NEGATIVE PAYMENT AMOUNT FOUND",!?2,"Bills will be marked Not To Post to accommodate"
+21 ;bar*1.8*20 REQ4
IF BARFLG=0
WRITE !,?6,"E-Bill#",?27,"E-Pymt",?39,"E-Claim Status Code"
+22 SET BARFLG=1
+23 ;Save Negative amount check number
SET BARSCK=BARVCK
+24 SET BARCNT=+$GET(BARCNT)+1
+25 SET EAMT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
+26 SET EBILL=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U)
+27 SET ^XTMP("BAR-REV",$JOB,DUZ(2),BARCDA)=EBILL
+28 WRITE !,BARCNT,?6,EBILL,?27,$FNUMBER(EAMT,",",2),?39,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,11)
+29 DO UP(IMPDA,BARCDA,"NEGP")
+30 SET REVAMT=+$GET(REVAMT)+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
End DoDot:2
End DoDot:1
+31 IF BARFLG
SET BAR="NEGP"
DO REVFIND
+32 ;bar*1.8*20 REQ4
IF 'BARFLG
WRITE "No Negative Payments found "
+33 QUIT BARFLG
+34 ;
LOOP(IMPDA,REASON,VCHK) ;EP; LOOP THROUGH BAREDI("I",IMPDA AND FLAG NOT TO POST
+1 ;
+2 NEW BARCDA,TCHK
+3 SET BARCDA=0
+4 FOR
SET BARCDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA))
IF 'BARCDA
QUIT
Begin DoDot:1
+5 ;Transaction check #
SET TCHK=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,2)),U)
+6 ; Limit it to just the one check
IF TCHK'=VCHK
QUIT
+7 DO UP(IMPDA,BARCDA,REASON)
End DoDot:1
+8 QUIT
+9 ;
UP(IMPDA,XCLM,REASON) ;EP; UPDATE STATUS
+1 KILL DIR,DIE,DA,DIC,DR,X
+2 KILL DIR,DIE,DA,DIC,DR
+3 SET DIC("P")=$PIECE(^DD(90056.0205,401,0),U,2)
+4 SET DA(2)=IMPDA
+5 SET DA(1)=XCLM
+6 SET DIC(0)="L"
+7 SET DIC="^BAREDI(""I"",DUZ(2),"_DA(2)_",30,"_DA(1)_",4,"
+8 SET X=REASON
+9 DO ^DIC
+10 QUIT
+11 ;start new code bar*1.8*20 REQ4
PLBFIND ; EP
+1 ;first put all bills for check into bill amount order
+2 SET CLMDA=0
+3 KILL ^XTMP("BAR-MBAMT",$JOB,DUZ(2))
+4 FOR
SET CLMDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA))
IF 'CLMDA
QUIT
Begin DoDot:1
+5 ;only my check
IF ($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)'=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U))
QUIT
+6 ;already posted
IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)="P"
QUIT
+7 ;not a payment
IF (("1^2^3^19^20^21^")'[("^"_$PIECE($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)," | ")_"^"))
QUIT
+8 SET CHKREASN=$$RCHK
+9 ;if ERA claim has already been marked NTP for PLB, lessen PLB amount by that ERA claim amount
+10 IF BARRCHK=1
IF ((CHKREASN)="PLB")
Begin DoDot:2
+11 SET PLBAMT=PLBAMT-$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)
+12 WRITE !?5,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)_" for $"_$JUSTIFY($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),2)_" was marked Not To Post"
End DoDot:2
QUIT
+13 ;E-payment
SET ^XTMP("BAR-MBAMT",$JOB,DUZ(2),$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)=""
End DoDot:1
+14 SET BAMT=0
SET BARDONE=0
+15 IF PLBAMT=0!(PLBAMT<0)
QUIT
+16 FOR
SET BAMT=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),BAMT))
IF 'BAMT
QUIT
Begin DoDot:1
+17 ;bill amount must be = or > than PLB amount
IF (BAMT<PLBAMT)
QUIT
+18 ;get first claim with that amount
SET CLMDA=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),BAMT,0))
+19 ;by here the BAMT should be as much or more than the PLB amount
+20 ;mark bill Not To Post
DO UP(IMPDA,CLMDA,"PLB")
+21 SET BARDONE=1
+22 WRITE !?2,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)_" for $"_$JUSTIFY($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),2)_" was marked Not To Post"
End DoDot:1
IF BARDONE
QUIT
+23 ;stop here if a bill was found and marked Not To Post
IF BARDONE
QUIT
+24 SET BAMT=99999999999
+25 FOR
SET BAMT=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),BAMT),-1)
IF 'BAMT
QUIT
Begin DoDot:1
+26 SET CLMDA=999999
+27 FOR
SET CLMDA=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),BAMT,CLMDA),-1)
IF 'CLMDA
QUIT
Begin DoDot:2
+28 ;mark bill Not To Post
DO UP(IMPDA,CLMDA,"PLB")
+29 SET PLBAMT=PLBAMT-BAMT
+30 IF PLBAMT=0!(PLBAMT<0)
SET BARDONE=1
+31 WRITE !?5,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)_" for $"_$JUSTIFY($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),2)_" was marked Not To Post"
End DoDot:2
IF BARDONE
QUIT
End DoDot:1
IF BARDONE
QUIT
+32 WRITE !
+33 QUIT
REVFIND ;EP
+1 ;find pymt to "counter" either payment reversal or negative payment and mark it Not To Post
+2 ;payment can be either on same bill, or different bill, or over several bills to "cover" amount
+3 ;total amount that needs to be written off
SET MTCHAMT=$SELECT(REVAMT<0:(REVAMT*-1),1:REVAMT)
+4 DO BUILDLST
+5 ;bills have already been marked Not To Post
IF MTCHAMT<0
QUIT
+6 ;go through list first time looking for amount on same claim
+7 SET REVDA=0
SET BARDONE=0
+8 SET EDA=0
+9 FOR
SET EDA=$ORDER(^XTMP("BAR-REV",$JOB,DUZ(2),EDA))
IF 'EDA
QUIT
Begin DoDot:1
+10 SET EBILL=$GET(^XTMP("BAR-REV",$JOB,DUZ(2),EDA))
+11 SET EAMT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,EDA,0)),U,4)
+12 ;bar*1.8*26 IHS/SD/SDR HEAT263595 ;bar*1.8*28 IHS/SD/SDR CR8346 HEAT275351
IF $DATA(^BAREDI("I",DUZ(2),IMPDA,30,EDA,4))>10
QUIT
+13 SET EAMT=EAMT*-1
+14 IF $DATA(^XTMP("BAR-BILLS",$JOB,DUZ(2),EBILL))
Begin DoDot:2
+15 SET MDA=0
+16 FOR
SET MDA=$ORDER(^XTMP("BAR-BILLS",$JOB,DUZ(2),EBILL,MDA))
IF 'MDA
QUIT
Begin DoDot:3
+17 SET MAMT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,EDA,0)),U,4)
+18 IF EAMT=MAMT
Begin DoDot:4
+19 SET RCLMDA=$ORDER(^XTMP("BAR-BILLS",$JOB,DUZ(2),EBILL,MDA,0))
+20 DO UP(IMPDA,RCLMDA,$SELECT(BAR="REV":"REV",1:"NEGP"))
+21 SET MTCHAMT=MTCHAMT-MAMT
+22 WRITE !?6,EBILL,?27,$JUSTIFY(MAMT,",",2),?39,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U,11)
+23 KILL ^XTMP("BAR-BILLS",$JOB,DUZ(2),EBILL,MDA)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 IF MTCHAMT>0
Begin DoDot:1
+25 SET MAMT=0
+26 FOR
SET MAMT=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),MAMT))
IF 'MAMT
QUIT
Begin DoDot:2
+27 SET MDA=0
+28 FOR
SET MDA=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),MAMT,MDA))
IF 'MDA
QUIT
Begin DoDot:3
+29 ;bar*1.8*28 IHS/DIT/CPC CR9572
IF $DATA(^BAREDI("I",DUZ(2),IMPDA,30,MDA,4))>10
QUIT
+30 IF MTCHAMT'=MAMT
QUIT
+31 ;S RCLMDA=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),EBILL,MDA,0))
+32 DO UP(IMPDA,MDA,$SELECT(BAR="REV":"REV",1:"NEGP"))
+33 SET MTCHAMT=MTCHAMT-MAMT
+34 WRITE !?6,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U),?27,$JUSTIFY(MAMT,",",2),?39,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U,11)
End DoDot:3
End DoDot:2
End DoDot:1
+35 IF MTCHAMT>0
Begin DoDot:1
+36 SET MAMT=999999999
+37 FOR
SET MAMT=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),MAMT),-1)
IF 'MAMT
QUIT
Begin DoDot:2
+38 SET MDA=0
+39 FOR
SET MDA=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),MAMT,MDA))
IF 'MDA
QUIT
Begin DoDot:3
+40 ;bar*1.8*28 IHS/DIT/CPC CR9572
IF $DATA(^BAREDI("I",DUZ(2),IMPDA,30,MDA,4))>10
QUIT
+41 DO UP(IMPDA,MDA,$SELECT(BAR="REV":"REV",1:"NEGP"))
+42 SET MTCHAMT=MTCHAMT-MAMT
+43 WRITE !?6,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U),?27,$JUSTIFY(MAMT,",",2),?39,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U,11)
End DoDot:3
IF ((MTCHAMT=0)!(MTCHAMT<0))
QUIT
End DoDot:2
IF ((MTCHAMT=0)!(MTCHAMT<0))
QUIT
End DoDot:1
IF ((MTCHAMT=0)!(MTCHAMT<0))
QUIT
+44 WRITE !
+45 QUIT
BUILDLST ;EP
+1 SET CLMDA=0
+2 KILL ^XTMP("BAR-MBAMT",$JOB,DUZ(2)),^XTMP("BAR-BILLS",$JOB,DUZ(2))
+3 FOR
SET CLMDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA))
IF 'CLMDA
QUIT
Begin DoDot:1
+4 ;only my check
IF ($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)'=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U))
QUIT
+5 ;already posted
IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="P"
QUIT
+6 ;bill is reversal
IF $DATA(^XTMP("BAR-REV",$JOB,DUZ(2),CLMDA))
QUIT
+7 SET CHKREASN=$$RCHK
+8 ;if ERA claim has already been marked NTP for PLB, lessen PLB amount by that ERA claim amount
+9 IF BARRCHK=1
IF ((CHKREASN)=$SELECT(BAR="REV":"REV",1:"NEGP"))
Begin DoDot:2
+10 ;bar*1.8*28 IHS/DIT/CPC CR9572
SET MTCHAMT=MTCHAMT-(+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4))
+11 WRITE !?6,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U),?27,$JUSTIFY($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),",",2),?39,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)
End DoDot:2
QUIT
+12 ;E-payment ;bar*1.8*28 IHS/DIT/CPC CR9572
SET ^XTMP("BAR-MBAMT",$JOB,DUZ(2),+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)=""
+13 ;bills
SET ^XTMP("BAR-BILLS",$JOB,DUZ(2),$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U),+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)=""
End DoDot:1
+14 QUIT
RCHK(CHKREASN) ;
+1 SET BARRCHK=0
SET CHKREASN=""
+2 ;no reasons not to post
IF '$DATA(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4))
QUIT CHKREASN
+3 SET BARNTPR=0
+4 FOR
SET BARNTPR=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,BARNTPR))
IF 'BARNTPR
QUIT
Begin DoDot:1
+5 IF "^PLB^REV^NEGP^"[("^"_$PIECE($GET(^BARERR($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,BARNTPR,0)),U),0)),U)_"^")
Begin DoDot:2
+6 SET BARRCHK=1
+7 SET CHKREASN=$PIECE($GET(^BARERR($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,BARNTPR,0)),U),0)),U)
End DoDot:2
End DoDot:1
IF CHKREASN
QUIT
+8 QUIT CHKREASN
+9 ;end new code REQ4
ISREV(IMPDA,CLMDA) ;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 ;----------------
