BAR50P0Z ; IHS/SD/LSL - MATCH REASONS AND CLAIMS ; 01/30/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**10,20,21,23,24,26,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
; HEAT148388 P.OTT 1/10/2014 ACCEPT REVERSALS FOR TYPE= 1 IF NEG PAYMENT FIX: 1/27/2014
; HEAT147572 P.OTT ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS
;IHS/SD/SDR - 1.8*26 Including routine in build but no changes were made. It looks like changes may have been made at sites
; so sending out routine to get everyone on the same page, right or wrong. What I saw at one site was EN+3 being commented out
; which causes payment reversal message to display no matter how the A/R parameter for allow neg bal is answered.
;IHS/SD/SDR 1.8*28 - CR8346 HEAT275351 - Made fix for check on reason NTP present.
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
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
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) ;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
.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
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
..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
..;W !!?5,"Negative Payment Amount found, all transactions" ;bar*1.8*20 REQ4
..;D LOOP^BAREDP0Z(IMPDA,"NEGP",BARVCK) ;Mark all NOT TO POST ;bar*1.8*20 REQ4
..S BARSCK=BARVCK ;Save Negative amount check number
..;Start new code bar*1.8*20 REQ4
..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
;end new code REQ4
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
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 ;bar*1.8*26 IHS/SD/SDR HEAT263595
.Q:(("^1^2^3^19^20^21^")'[("^"_$P($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)," | ")_"^")) ;not a payment ;bar*1.8*26 IHS/SD/SDR HEAT263595
.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 ;bar*1.8*26 IHS/SD/SDR HEAT263595
.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*26 IHS/SD/SDR HEAT263595
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)) Q ;bar*1.8*26 IHS/SD/SDR HEAT263595 ;bar*1.8*28 IHS/SD/SDR CR8346 HEAT275351
.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)) Q ;bar*1.8*26 IHS/SD/SDR HEAT263595
...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)) Q ;bar*1.8*26 IHS/SD/SDR HEAT263595
...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*26 IHS/SD/SDR HEAT263595
..S MTCHAMT=MTCHAMT-(+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)) ;bar*1.8*26 IHS/SD/SDR HEAT263595
..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*26 IHS/SD/SDR HEAT263595
.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*26 IHS/SD/SDR HEAT263595
.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
I +$$GET1^DIQ(90056.0205,CLMDA_","_IMPDA_",",.11)=22 Q 1
;;;I +$$GET1^DIQ(90056.0205,CLMDA_","_IMPDA_",",.11)=1 I +$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)<0 Q 1
Q 0
;----------------
BAR50P0Z ; IHS/SD/LSL - MATCH REASONS AND CLAIMS ; 01/30/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**10,20,21,23,24,26,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 ; HEAT148388 P.OTT 1/10/2014 ACCEPT REVERSALS FOR TYPE= 1 IF NEG PAYMENT FIX: 1/27/2014
+5 ; HEAT147572 P.OTT ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS
+6 ;IHS/SD/SDR - 1.8*26 Including routine in build but no changes were made. It looks like changes may have been made at sites
+7 ; so sending out routine to get everyone on the same page, right or wrong. What I saw at one site was EN+3 being commented out
+8 ; which causes payment reversal message to display no matter how the A/R parameter for allow neg bal is answered.
+9 ;IHS/SD/SDR 1.8*28 - CR8346 HEAT275351 - Made fix for check on reason NTP present.
+10 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 ;HEAT147572
IF '$$IHSNEGB^BARUFUT(DUZ(2))
QUIT 0
+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 ;bar*1.8*20 REQ4
WRITE !!,"Looking for Payment Reversals... "
+2 NEW BARCDA,BAR15,BARAMT,CNT,BARVCK,BARSCK
+3 SET BARCDA=0
+4 SET (BARVCK,BARSCK)=""
+5 SET BAR="REV"
+6 SET REVAMT=0
+7 SET BARCNT=0
+8 ;was K ^XTMP("BAR=REV",$J)
KILL ^XTMP("BAR-REV",$JOB)
+9 FOR CNT=1:1
SET BARCDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA))
IF 'BARCDA
QUIT
Begin DoDot:1
+10 ;W:'(CNT#1000) "." ;bar*1.8*20 REQ4
+11 ;;old code Q:(+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,11)'=22) ;only looking for REVERSALS
+12 ;new code P.OTT 1/10/2014 HEAT148388 1/24/2024 PARAMETER PASSING
IF '$$ISREV(IMPDA,BARCDA)
QUIT
+13 ;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
+14 IF BARFLG=0
Begin DoDot:2
+15 WRITE "PAYMENT REVERSAL FOUND",!?3,"Bills will be marked Not To Post to accommodate "
+16 WRITE !,?6,"E-Bill#",?27,"E-Pymt",?39,"E-Claim Status Code"
End DoDot:2
+17 SET BARFLG=1
+18 SET BARCNT=+$GET(BARCNT)+1
+19 SET EAMT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
+20 SET EBILL=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U)
+21 SET ESTAT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,11)
+22 SET ^XTMP("BAR-REV",$JOB,DUZ(2),BARCDA)=EBILL
+23 WRITE !,BARCNT,?6,EBILL,?27,$FNUMBER(EAMT,",",2),?39,ESTAT
+24 DO UP(IMPDA,BARCDA,"REV")
+25 SET REVAMT=+$GET(REVAMT)-$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
End DoDot:1
+26 IF BARFLG
DO REVFIND
+27 ;No Payment Reversals
IF 'BARFLG
WRITE "No Payment Reversals found"
QUIT BARFLG
+28 ;end new code REQ4
+29 QUIT BARFLG
+30 ;
NEGP(IMPDA) ;EP ;D159-1
+1 ;W !,"Looking for Negative Payments " ;bar*1.8*20 REQ4
+2 ;bar*1.8*20 REQ4
WRITE !!,"Looking for Negative Payments... "
+3 NEW BARCDA,BAR300,BARAMT,CNT,BARSTA,BAR302,BARVCK,BARSCK
+4 SET BARCDA=0
+5 SET BARSCK=""
+6 ;bar*1.8*20 REQ4
SET BARCNT=0
SET REVAMT=0
+7 FOR CNT=1:1
SET BARCDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA))
IF 'BARCDA
QUIT
Begin DoDot:1
+8 ;W:'(CNT#1000) "." ;bar*1.8*20 REQ4
+9 SET BAR300=$GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0))
+10 SET BAR302=$GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,2))
+11 ;Check number
SET BARVCK=$PIECE(BAR302,U)
+12 SET BARSTA=+$PIECE(BAR300,U,11)
+13 IF BARSTA=""
SET BARSTA=$PIECE(BAR302,U,4)
+14 ;Only want PAYMENTS & DENIALS
IF (U_"1"_U_"2"_U_"3"_U_"4"_U_"19"_U_"20"_U_"21"_U)'[(U_BARSTA_U)
QUIT
+15 ;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
+16 SET BARAMT=$PIECE(BAR300,U,4)
+17 IF BARAMT<0
Begin DoDot:2
+18 ;Q:BARVCK=BARSCK ;Only process once for each check P.OTTIS HEAT148388
+19 ;bar*1.8*20 REQ4
IF BARFLG=0
WRITE "NEGATIVE PAYMENT AMOUNT FOUND",!?2,"Bills will be marked Not To Post to accommodate"
+20 ;bar*1.8*20 REQ4
IF BARFLG=0
WRITE !,?6,"E-Bill#",?27,"E-Pymt",?39,"E-Claim Status Code"
+21 SET BARFLG=1
+22 ;W !!?5,"Negative Payment Amount found, all transactions" ;bar*1.8*20 REQ4
+23 ;D LOOP^BAREDP0Z(IMPDA,"NEGP",BARVCK) ;Mark all NOT TO POST ;bar*1.8*20 REQ4
+24 ;Save Negative amount check number
SET BARSCK=BARVCK
+25 ;Start new code bar*1.8*20 REQ4
+26 SET BARCNT=+$GET(BARCNT)+1
+27 SET EAMT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
+28 SET EBILL=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U)
+29 SET ^XTMP("BAR-REV",$JOB,DUZ(2),BARCDA)=EBILL
+30 WRITE !,BARCNT,?6,EBILL,?27,$FNUMBER(EAMT,",",2),?39,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,11)
+31 DO UP(IMPDA,BARCDA,"NEGP")
+32 SET REVAMT=+$GET(REVAMT)+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCDA,0)),U,4)
End DoDot:2
End DoDot:1
+33 IF BARFLG
SET BAR="NEGP"
DO REVFIND
+34 ;end new code REQ4
+35 ;bar*1.8*20 REQ4
IF 'BARFLG
WRITE "No Negative Payments found "
+36 QUIT BARFLG
+37 ;
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
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 ;Q:(("1^2^3^19^20^21^")'[("^"_$P($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)," | ")_"^")) ;not a payment ;bar*1.8*26 IHS/SD/SDR HEAT263595
+8 ;not a payment ;bar*1.8*26 IHS/SD/SDR HEAT263595
IF (("^1^2^3^19^20^21^")'[("^"_$PIECE($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)," | ")_"^"))
QUIT
+9 SET CHKREASN=$$RCHK
+10 ;if ERA claim has already been marked NTP for PLB, lessen PLB amount by that ERA claim amount
+11 IF BARRCHK=1
IF ((CHKREASN)="PLB")
Begin DoDot:2
+12 SET PLBAMT=PLBAMT-$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)
+13 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
+14 ;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*26 IHS/SD/SDR HEAT263595
+15 ;E-payment ;bar*1.8*26 IHS/SD/SDR HEAT263595
SET ^XTMP("BAR-MBAMT",$JOB,DUZ(2),+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)=""
End DoDot:1
+16 SET BAMT=0
SET BARDONE=0
+17 IF PLBAMT=0!(PLBAMT<0)
QUIT
+18 FOR
SET BAMT=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),BAMT))
IF 'BAMT
QUIT
Begin DoDot:1
+19 ;bill amount must be = or > than PLB amount
IF (BAMT<PLBAMT)
QUIT
+20 ;get first claim with that amount
SET CLMDA=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),BAMT,0))
+21 ;by here the BAMT should be as much or more than the PLB amount
+22 ;mark bill Not To Post
DO UP(IMPDA,CLMDA,"PLB")
+23 SET BARDONE=1
+24 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
+25 ;stop here if a bill was found and marked Not To Post
IF BARDONE
QUIT
+26 SET BAMT=99999999999
+27 FOR
SET BAMT=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),BAMT),-1)
IF 'BAMT
QUIT
Begin DoDot:1
+28 SET CLMDA=999999
+29 FOR
SET CLMDA=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),BAMT,CLMDA),-1)
IF 'CLMDA
QUIT
Begin DoDot:2
+30 ;mark bill Not To Post
DO UP(IMPDA,CLMDA,"PLB")
+31 SET PLBAMT=PLBAMT-BAMT
+32 IF PLBAMT=0!(PLBAMT<0)
SET BARDONE=1
+33 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
+34 WRITE !
+35 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 ;I $D(^BAREDI("I",DUZ(2),IMPDA,30,EDA,4)) Q ;bar*1.8*26 IHS/SD/SDR HEAT263595 ;bar*1.8*28 IHS/SD/SDR CR8346 HEAT275351
+13 ;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
+14 SET EAMT=EAMT*-1
+15 IF $DATA(^XTMP("BAR-BILLS",$JOB,DUZ(2),EBILL))
Begin DoDot:2
+16 SET MDA=0
+17 FOR
SET MDA=$ORDER(^XTMP("BAR-BILLS",$JOB,DUZ(2),EBILL,MDA))
IF 'MDA
QUIT
Begin DoDot:3
+18 SET MAMT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,EDA,0)),U,4)
+19 IF EAMT=MAMT
Begin DoDot:4
+20 SET RCLMDA=$ORDER(^XTMP("BAR-BILLS",$JOB,DUZ(2),EBILL,MDA,0))
+21 DO UP(IMPDA,RCLMDA,$SELECT(BAR="REV":"REV",1:"NEGP"))
+22 SET MTCHAMT=MTCHAMT-MAMT
+23 WRITE !?6,EBILL,?27,$JUSTIFY(MAMT,",",2),?39,$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,MDA,0)),U,11)
+24 KILL ^XTMP("BAR-BILLS",$JOB,DUZ(2),EBILL,MDA)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 IF MTCHAMT>0
Begin DoDot:1
+26 SET MAMT=0
+27 FOR
SET MAMT=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),MAMT))
IF 'MAMT
QUIT
Begin DoDot:2
+28 SET MDA=0
+29 FOR
SET MDA=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),MAMT,MDA))
IF 'MDA
QUIT
Begin DoDot:3
+30 ;I $D(^BAREDI("I",DUZ(2),IMPDA,30,MDA,4)) Q ;bar*1.8*26 IHS/SD/SDR HEAT263595
+31 ;bar*1.8*28 IHS/DIT/CPC CR9572
IF $DATA(^BAREDI("I",DUZ(2),IMPDA,30,MDA,4))>10
QUIT
+32 IF MTCHAMT'=MAMT
QUIT
+33 ;S RCLMDA=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),EBILL,MDA,0))
+34 DO UP(IMPDA,MDA,$SELECT(BAR="REV":"REV",1:"NEGP"))
+35 SET MTCHAMT=MTCHAMT-MAMT
+36 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
+37 IF MTCHAMT>0
Begin DoDot:1
+38 SET MAMT=999999999
+39 FOR
SET MAMT=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),MAMT),-1)
IF 'MAMT
QUIT
Begin DoDot:2
+40 SET MDA=0
+41 FOR
SET MDA=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),MAMT,MDA))
IF 'MDA
QUIT
Begin DoDot:3
+42 ;I $D(^BAREDI("I",DUZ(2),IMPDA,30,MDA,4)) Q ;bar*1.8*26 IHS/SD/SDR HEAT263595
+43 ;bar*1.8*28 IHS/DIT/CPC CR9572
IF $DATA(^BAREDI("I",DUZ(2),IMPDA,30,MDA,4))>10
QUIT
+44 DO UP(IMPDA,MDA,$SELECT(BAR="REV":"REV",1:"NEGP"))
+45 SET MTCHAMT=MTCHAMT-MAMT
+46 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
+47 WRITE !
+48 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 ;S MTCHAMT=MTCHAMT-$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4) ;bar*1.8*26 IHS/SD/SDR HEAT263595
+11 ;bar*1.8*26 IHS/SD/SDR HEAT263595
SET MTCHAMT=MTCHAMT-(+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4))
+12 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
+13 ;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*26 IHS/SD/SDR HEAT263595
+14 ;E-payment ;bar*1.8*26 IHS/SD/SDR HEAT263595
SET ^XTMP("BAR-MBAMT",$JOB,DUZ(2),+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)=""
+15 ;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
+16 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
+1 IF +$$GET1^DIQ(90056.0205,CLMDA_","_IMPDA_",",.11)=22
QUIT 1
+2 ;;;I +$$GET1^DIQ(90056.0205,CLMDA_","_IMPDA_",",.11)=1 I +$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)<0 Q 1
+3 QUIT 0
+4 ;----------------
