RCDPEWL6 ;ALB/TMK/KML - ELECTRONIC EOB WORKLIST ACTIONS ;Jun 06, 2014@19:11:19
;;4.5;Accounts Receivable;**173,208,222,276,298,303,318,326**;Mar 20, 1995;Build 26
;;Per VA Directive 6402, this routine should not be modified.
Q
;
DISTADJ ;EP - Protocol action - RCDPE EOB WORKLIST DIST ADJ
; Distribute an adjustment that retracts a payment to other bill(s)
;
; Input - RCSCR - Scratchpad #344.49 IEN
;
N RCDA,RCDA1,RCAMT,RCADJ,RCQUIT,Z,Z0,Z1,DIR,X,Y,CT,RCZ,RCZ1,RCZ2,RCADJOK,TOT,DTOUT,DUOUT
N RCNONSP,RCACTIVE,RCZZ1,RCZZ2,RCADJSTR ; prca276 - variables used to establish non-specific payment adjustments and AR BILL claim status (fix to negative claim balance issue)
D FULL^VALM1
I $S($P($G(^RCY(344.4,RCSCR,4)),U,2)]"":1,1:0) D NOEDIT^RCDPEWLP G DISTQ ;prca*4.5*298 auto-posted ERAs cannot enter dISTRIBUTE ADJ AMTS action
I $G(RCSCR("NOEDIT")) D NOEDIT^RCDPEWL G DISTQ
I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL G DISTQ
;
S Z=0,RCADJOK="" F S Z=$O(^TMP("RCDPE-EOB_WLDX",$J,Z)) Q:'Z S Z1=+$P($G(^(Z)),U,2),Z0=$G(^RCY(344.49,RCSCR,1,Z1,0)) D
. I $P(Z0,U)'["." S RCADJOK=($P(Z0,U,2)["**ADJ") Q
. ; Following validation line removed - allow distribution to non-VA claims - PRCA*4.5*326
. ;I '$P(Z0,U,7),'RCADJOK Q ; Suspense item cannot be used to adjust
. I $P(Z0,U,6)<0 S RCZ(Z)=$P(Z0,U,6)_U_Z1 Q
. I $P(Z0,U,6)>0 D Q
.. N Q,ONHLD,IBA
.. S ONHLD=0
.. I $P(Z0,U,7) I $$IB^IBRUTL(+$P(Z0,U,7),1) S Q=0 F S Q=$O(IBA(Q)) Q:'Q I $P($G(^IB(+IBA(Q),0)),U,5)=8 S ONHLD=1 Q
.. S RCZ1(+$P(Z0,U,6),Z)=Z1_U_ONHLD,RCZ2(Z)=Z1_U_$P(Z0,U,6)_U_ONHLD Q
;
I $O(RCZ(0))="" D G DISTQ
. S DIR(0)="EA",DIR("A",1)="NO LINES EXIST NEEDING ADJUSTMENT DISTRIBUTION",DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
;
I $O(RCZ1(0))="" D G DISTQ
. S DIR(0)="EA",DIR("A",1)="NO VALID LINES EXIST ON THIS ERA WHERE A DISTRIBUTION CAN BE MADE",DIR("A",2)=$$WHAT(RCSCR),DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
;
S RCQUIT=0
F S DIR(0)="NA^1:9999:3",DIR("A")="SELECT A LINE THAT NEEDS AN ADJUSTMENT AMOUNT DISTRIBUTED: " D Q:RCQUIT
. S DIR("?",1)="THE FOLLOWING LINE(S) HAVE AN ADJUSTMENT THAT CAUSED A NEGATIVE NET PAYMENT.",DIR("?",2)="IN ORDER TO BALANCE THE RECEIPT AND THE DEPOSIT, THESE AMOUNTS WILL NEED TO",DIR("?",3)=" BE DISTRIBUTED TO OTHER LINE(S)",CT=3
. S Z=0
. F S Z=$O(RCZ(Z)) Q:'Z S CT=CT+1,DIR("?",CT)=" "_$J(Z,8)_" "_$J($P(RCZ(Z),U),15,2)
. S DIR("?")=" "
. I $O(RCZ(0))=$O(RCZ(""),-1) S DIR("B")=$O(RCZ(0))
. W ! D ^DIR K DIR
. I $D(DUOUT)!$D(DTOUT)!(Y="") S RCQUIT=1,RCDA="" Q
. I '$D(^TMP("RCDPE-EOB_WLDX",$J,Y)) W !,"THIS LINE DOES NOT EXIST FOR THIS ERA" W ! Q
. I '$D(RCZ(Y)) D Q:Y=""
.. I Y'[".",$D(RCZ(Y_".001")),$O(RCZ(Y+1),-1)=(Y_".001") S Y=Y_".001" Q
.. W !,$S(Y["."!($O(RCZ(Y))\1'=(Y\1)):"THIS LINE DOESN'T NEED AN ADJUSTMENT DISTRIBUTION",1:"PLEASE ENTER THE ENTIRE LINE # (Such as: 1.001)") W !
.. S Y=""
. W !," LINE #: "_+Y_" AMOUNT NEEDED TO DISTRIBUTE: "_$J(+RCZ(Y),"",2),!
. ; RCDA = the ien of the line in file 344.491
. ; RCDA(1) = the line # RCDA(2) = the amount to be adjusted (+)
. S RCDA=$P(RCZ(Y),U,2),RCDA(1)=Y,RCQUIT=1,RCDA(2)=-$P(RCZ(Y),U)
;
G:$G(RCDA)="" DISTQ
;
S RCQUIT=0
;
; PRCA*4.5*303 - May miss if multiple amounts are equal, changed calculation to use RCZ2 instead of RCZ1
; Old code: S (TOT,Z)=0 F S Z=$O(RCZ1(Z)) Q:'Z S TOT=TOT+Z
S (TOT,Z)=0 F S Z=$O(RCZ2(Z)) Q:'Z S TOT=TOT+$P(RCZ2(Z),U,2)
I TOT<RCDA(2) D G DISTQ
. S DIR(0)="EA",DIR("A",1)="THE ERA DOES NOT HAVE ENOUGH VALID PAYMENTS TO OFFSET THIS DISTRIBUTION",DIR("A",2)=$$WHAT(RCSCR),DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
F S DIR(0)="NA^1:9999:3",DIR("A")="SELECT A LINE TO DISTRIBUTE THE ADJUSTMENT AMOUNT TO: " D Q:RCQUIT
. S DIR("?",1)="THE FOLLOWING LINE(S) HAVE A NET PAYMENT THAT CAN BE USED TO OFFSET THE",DIR("?",2)=" NEGATIVE NET PAYMENT FOR LINE "_RCDA(1)_" ("_$J(+$P(RCZ(RCDA(1)),U),"",2)_"):",CT=2
. S Z="" F S Z=$O(RCZ1(Z),-1) Q:'Z S Z0=0 F S Z0=$O(RCZ1(Z,Z0)) Q:'Z0 S CT=CT+1,DIR("?",CT)=" "_$J(Z0,8)_" "_$J(+Z,15,2)_$S($P(RCZ1(Z,Z0),U,2):" On hold exists",1:"")
. S DIR("?")=" "
. I $O(RCZ2(0))=$O(RCZ2(""),-1) S DIR("B")=$O(RCZ2(0))
. W ! D ^DIR K DIR
. I $D(DUOUT)!$D(DTOUT)!(Y="") S RCQUIT=1,RCDA1="" Q
. I '$D(^TMP("RCDPE-EOB_WLDX",$J,Y)) W !,"THIS LINE DOES NOT EXIST FOR THIS ERA" W ! Q
. I '$D(RCZ2(Y)) D Q:Y=""
.. I Y'[".",$D(RCZ2(Y_".001")),$O(RCZ2(Y+1),-1)=(Y_".001") S Y=Y_".001" Q
.. I Y'[".",$O(RCZ2(Y))\1'=Y S Y=Y_"."
.. W !,$S(Y[".":"THIS LINE CANNOT BE USED FOR AN ADJUSTMENT DISTRIBUTION",1:"PLEASE ENTER THE ENTIRE LINE # (Such as: 1.001)") W !
.. S Y=""
. ; prca276 - next few lines represent the a fix to prevent distributions agains collected/closed claims (claim balance = zero dollars)
. ;distributions should only occur on line items that have specific payments against active claims
. S RCZZ1=$P(^TMP("RCDPE-EOB_WLDX",$J,Y),U,2) ; get line item sequence # off the VIEW order before accessing the scratchpad
. S (RCZZ2,RCNONSP)=0 F S RCZZ2=$O(^RCY(344.49,RCSCR,1,RCZZ1,1,RCZZ2)) Q:'RCZZ2 Q:RCNONSP S RCADJSTR=$G(^(RCZZ2,0)) S RCNONSP=$S($P(RCADJSTR,U,2)=3:1,$P(RCADJSTR,U,2)=5:1,1:0) ;identify if non-specific payment adjustments exist
. ; do not evaluate claim status for non-specific payment adjustments
. ; or distributions to non-VistA claims - PRCA*4.5*326
. I 'RCNONSP,$P(^RCY(344.49,RCSCR,1,RCZZ1,0),U,7) D Q:'RCACTIVE ; PRCA*4.5*326
. . S RCACTIVE=$$GET1^DIQ(430,$P(^RCY(344.49,RCSCR,1,RCZZ1,0),U,7),8)
. . I (RCACTIVE'="ACTIVE")&(RCACTIVE'="OPEN") S RCACTIVE=0 W !,"THIS IS NOT AN ACTIVE BILL !",!,"CANNOT PERFORM DISTRIBUTION TO THIS CLAIM",! Q
. . S RCACTIVE=1
. I $P(RCZ2(Y),U,3) W !,"Warning - on-hold exists for this claim",!
. W !," LINE #: "_+Y_" LINE BALANCE: "_$J(+$P(RCZ2(Y),U,2),"",2),!
. ; RCDA1 = the ien of the line in file 344.491
. ; RCDA1(1) = the line # in the display
. S RCDA1(1)=Y,RCDA1=+$G(RCZ2(Y)),RCQUIT=1
. S Z=$O(^RCY(344.49,RCSCR,1,"B",RCDA1(1)\1,0))
. S RCADJ=0
. I $P($G(^RCY(344.49,RCSCR,1,Z,0)),U,2)["**ADJ" S RCADJ=1 W !,"THE LINE SELECTED IS AN ADDITIONAL PAYMENT LINE, NOT SPECIFIC TO A CLAIM",!,"THE AMT WILL BE DISTRIBUTED, BUT A DECREASE ADJUSTMENT WILL NOT BE PERFORMED",!
;
G:'$G(RCDA1) DISTQ
;
S DIR("B")=$S(RCDA(2)<$P(RCZ2(RCDA1(1)),U,2):$J(RCDA(2),"",2),1:$J($P(RCZ2(+RCDA1(1)),U,2),"",2))
S DIR(0)="NA^.01:"_DIR("B")_":2",DIR("A")="ADJUSTMENT AMOUNT TO DISTRIBUTE: "
S DIR("?",1)="THIS IS THE AMOUNT OF THE ADJUSTMENT THAT SHOULD BE APPLIED TO THIS",DIR("?")="PAYMENT LINE. THE AMT ENTERED MUST BE BETWEEN .01 AND "_$J(DIR("B"),"",2)
D ^DIR K DIR
;
I $D(DUOUT)!$D(DTOUT)!'Y D G DISTQ
. S DIR(0)="EA",DIR("A",1)="NO AMOUNT WAS ENTERED - TRY AGAIN LATER",DIR("A")="PRESS RETURN TO CONTINUE " D ^DIR K DIR
S RCAMT=$J(Y,"",2)
;
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) D G DISTQ
. S DIR(0)="EA",DIR("A")="USER ABORT - PRESS RETURN TO CONTINUE " D ^DIR K DIR
;
S Y=""
I 'RCADJ D G:'$D(RCDA) DISTQ
. N Z,RCA
. S RCA=0,Z1=+$P($G(^TMP("RCDPE-EOB_WLDX",$J,RCDA(1)\1)),U,2),Z=$G(^RCY(344.49,RCSCR,1,Z1,0)),RCA("#")=+$P($P(Z,U,2),"**ADJ",2)
. I $P(Z,U,2)["**ADJ" D
.. S RCA=1
.. S RCA("REF")=$S(RCA("#"):$P($G(^RCY(344.4,RCSCR,2,RCA("#"),0)),U),1:$P(Z,U,9))
. S Z=$S(RCA:RCA("#"),1:$G(^RCY(344.49,RCSCR,1,RCDA,0)))
. S DIR(0)="FAO^1:60",DIR("A")=" > ",DIR("A",1)="DECREASE ADJ COMMENT (1-60 CHARACTERS): "
. S DIR("B")="RETRACTED FOR "
. S DIR("B")=DIR("B")_$S(RCA:"ERA ADJ #"_Z_" Ref: "_RCA("REF"),1:"CLAIM "_$S($P(Z,U,2)'="":$P(Z,U,2),1:"UNKNOWN"))
. I $L(DIR("B"))>60 S DIR("B")=$E(DIR("B"),1,60)
. D ^DIR K DIR
. ;
. I $D(DUOUT)!$D(DTOUT) D Q
.. K RCDA
.. S DIR(0)="EA",DIR("A")="USER ABORT - PRESS RETURN TO CONTINUE " D ^DIR K DIR
;
D DISTADJ^RCDPEWL4(RCDA,RCDA1,RCAMT,Y)
;
DISTQ S VALMBCK="R"
Q
;
REFRESH ;EP - Protocol action - RCDPE EOB WORKLIST REFRESH
; Refresh the entry in file 344.49 to remove all user adjustments
N DA,DIK,DIR,RCQUIT,RCREDEF,X,Y,Z,Z0
D FULL^VALM1
I '$D(^XUSEC("RCDPEPP",DUZ)) D Q ; PRCA*4.5*318 Added security key check
. W !!,"This action can only be taken by users that have the RCDPEPP security key.",!
. D PAUSE^VALM1
. S VALMBCK="R"
I $S($P($G(^RCY(344.4,RCSCR,4)),U,2)]"":1,1:0) D NOEDIT^RCDPEWLP G REFQ ;prca*4.5*298 auto-posted ERAs cannot enter REFRESH SCRATCHPAD action
I $G(RCSCR("NOEDIT")) D NOEDIT^RCDPEWL G REFQ
; prca*4.5*298 per patch requirements, keep code related to creating/maintaining
; batches but just remove from execution
;I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL G REFQ ;prca*4.5*298
S DIR(0)="YA"
S DIR("A",1)="THIS ACTION WILL DELETE AND REBUILD THIS EEOB WORKLIST SCRATCH PAD ENTRY",DIR("A",2)="ALL EDITS/SPLITS/DISTRIBUTE ADJUSTMENTS ENTERED FOR THIS ERA WILL BE ERASED"
S DIR("A",3)="AND ALL ENTRIES MARKED AS MANUALLY VERIFIED WILL BE UNMARKED",DIR("A",4)=" "
S DIR("A")="ARE YOU SURE YOU WANT TO DO THIS?: "
W ! D ^DIR K DIR
I Y'=1 G REFQ
; prca*4.5*298 per patch requirements, keep code related to creating/maintaining
; batches but just remove from execution
;I $O(^RCY(344.49,RCSCR,3,0)) S RCQUIT=0 D I RCQUIT G REFQ
;. S DIR(0)="YA",DIR("A")="DO YOU WANT TO REDEFINE YOUR BATCHES TOO?: ",DIR("B")="NO" W ! D ^DIR K DIR
;. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
;. S RCREDEF=+Y
;. K ^TMP($J,"BATCHES")
;. S Z=0 F S Z=$O(^RCY(344.49,RCSCR,3,Z)) Q:'Z S Z0=$G(^(Z,0)) D
;.. I RCREDEF S DA=Z,DA(1)=RCSCR,DIK="^RCY(344.49,"_DA(1)_",3," D ^DIK Q
;.. S ^TMP($J,"BATCHES",+$P(Z0,U,6),$P(Z0,U,7))=+Z0_U_$P(Z0,U,8)
;. I 'RCREDEF S ^TMP($J,"BATCHES")=+$O(^TMP($J,"BATCHES",0))
;. I RCREDEF D SETBATCH^RCDPEWLB(RCSCR)
D ADDLINES^RCDPEWLA(RCSCR)
D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM")))
K ^TMP($J,"BATCHES")
REFQ S VALMBG=1,VALMBCK="R"
Q
;
WHAT(RCSCR) ; Text for what to do if not enough funds found for dist adj
Q $S($O(^RCY(344.31,"AERA",+RCSCR,0)):"THIS ERA MUST BE MOVED TO SUSPENSE",1:"THIS ERA'S RECEIPT MUST BE ENTERED MANUALLY")
;
ADJUST ; Allow entry into increase/decrease adjustment functions
N DIR,X,Y,RCTYP,RCY,DIC
D FULL^VALM1
;
I $G(RCSCR("NOEDIT"))=2 D NOTAV^RCDPEWL2 G ADJUSTQ
; PRCA*4.5*276 - check for authorized user
I '$D(^XUSEC("PRCADJ",DUZ)) D Q
.S DIR(0)="EA",DIR("A",1)="The Adjust (Inc/Dec) Action is locked."
.S DIR("A",2)="Please speak to your Supervisor to request the key."
.S DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
; PRCA*4.5*276 - end of changes
;
S DIR(0)="SA^D:DECREASE ADJUSTMENT;I:INCREASE ADJUSTMENT",DIR("B")="DECREASE ADJUSTMENT",DIR("A")="TYPE OF ADJUSTMENT: "
W ! D ^DIR K DIR
M ^TMP("RC_SAVE_TMP",$J)=^TMP($J)
I $D(DUOUT)!$D(DTOUT)!(Y="") G ADJUSTQ
;
S RCTYP=$S(Y="D":"DECREASE",1:"INCREASE")
F S RCY=$$GETABILL^RCBEUBIL Q:RCY<0!(RCY'<1)
G:RCY<1 ADJUSTQ
D ADJUST^RCBEADJ(RCTYP,RCY_";"_RCSCR)
I $D(^TMP("RC_BILL",$J,RCY)) D
. D UPDBAL(RCY)
. W !,"Claim balance is now: ",$J(+$P($$BILL^RCJIBFN2(RCY),U,3),"",2)
;
ADJUSTQ D RESTMP
D RET^RCDPEWL2
S VALMBCK="R"
Q
;
RESTMP ;
I $D(^TMP("RC_SAVE_TMP",$J)) M ^TMP($J)=^TMP("RC_SAVE_TMP",$J) K ^TMP("RC_SAVE_TMP")
Q
;
UPDBAL(RCY) ; Updates the claim balance if bill exists in list
; RCY = ien of bill in file 430
;
N X,Y,Z,Z0,Z1
S Z0=$J(+$P($$BILL^RCJIBFN2(RCY),U,3),"",2)
S Z=0 F S Z=$O(^TMP("RC_BILL",$J,RCY,Z)) Q:'Z D
. S X=+$G(^TMP("RCDPE-EOB_WLDX",$J,Z))
. Q:'X
. S Y=$G(^TMP("RCDPE-EOB_WL",$J,X+1,0))
. I Y["Claim Bal: " S Z1=$P(Y,"Claim Bal: ")_"Claim Bal: "_Z0_$G(^TMP("RC_BILL",$J,RCY,Z)),^TMP("RCDPE-EOB_WL",$J,X+1,0)=Z1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEWL6 11709 printed Oct 16, 2024@17:46:35 Page 2
RCDPEWL6 ;ALB/TMK/KML - ELECTRONIC EOB WORKLIST ACTIONS ;Jun 06, 2014@19:11:19
+1 ;;4.5;Accounts Receivable;**173,208,222,276,298,303,318,326**;Mar 20, 1995;Build 26
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
DISTADJ ;EP - Protocol action - RCDPE EOB WORKLIST DIST ADJ
+1 ; Distribute an adjustment that retracts a payment to other bill(s)
+2 ;
+3 ; Input - RCSCR - Scratchpad #344.49 IEN
+4 ;
+5 NEW RCDA,RCDA1,RCAMT,RCADJ,RCQUIT,Z,Z0,Z1,DIR,X,Y,CT,RCZ,RCZ1,RCZ2,RCADJOK,TOT,DTOUT,DUOUT
+6 ; prca276 - variables used to establish non-specific payment adjustments and AR BILL claim status (fix to negative claim balance issue)
NEW RCNONSP,RCACTIVE,RCZZ1,RCZZ2,RCADJSTR
+7 DO FULL^VALM1
+8 ;prca*4.5*298 auto-posted ERAs cannot enter dISTRIBUTE ADJ AMTS action
IF $SELECT($PIECE($GET(^RCY(344.4,RCSCR,4)),U,2)]"":1,1:0)
DO NOEDIT^RCDPEWLP
GOTO DISTQ
+9 IF $GET(RCSCR("NOEDIT"))
DO NOEDIT^RCDPEWL
GOTO DISTQ
+10 IF $GET(^TMP("RCBATCH_SELECTED",$JOB))
DO NOBATCH^RCDPEWL
GOTO DISTQ
+11 ;
+12 SET Z=0
SET RCADJOK=""
FOR
SET Z=$ORDER(^TMP("RCDPE-EOB_WLDX",$JOB,Z))
if 'Z
QUIT
SET Z1=+$PIECE($GET(^(Z)),U,2)
SET Z0=$GET(^RCY(344.49,RCSCR,1,Z1,0))
Begin DoDot:1
+13 IF $PIECE(Z0,U)'["."
SET RCADJOK=($PIECE(Z0,U,2)["**ADJ")
QUIT
+14 ; Following validation line removed - allow distribution to non-VA claims - PRCA*4.5*326
+15 ;I '$P(Z0,U,7),'RCADJOK Q ; Suspense item cannot be used to adjust
+16 IF $PIECE(Z0,U,6)<0
SET RCZ(Z)=$PIECE(Z0,U,6)_U_Z1
QUIT
+17 IF $PIECE(Z0,U,6)>0
Begin DoDot:2
+18 NEW Q,ONHLD,IBA
+19 SET ONHLD=0
+20 IF $PIECE(Z0,U,7)
IF $$IB^IBRUTL(+$PIECE(Z0,U,7),1)
SET Q=0
FOR
SET Q=$ORDER(IBA(Q))
if 'Q
QUIT
IF $PIECE($GET(^IB(+IBA(Q),0)),U,5)=8
SET ONHLD=1
QUIT
+21 SET RCZ1(+$PIECE(Z0,U,6),Z)=Z1_U_ONHLD
SET RCZ2(Z)=Z1_U_$PIECE(Z0,U,6)_U_ONHLD
QUIT
End DoDot:2
QUIT
End DoDot:1
+22 ;
+23 IF $ORDER(RCZ(0))=""
Begin DoDot:1
+24 SET DIR(0)="EA"
SET DIR("A",1)="NO LINES EXIST NEEDING ADJUSTMENT DISTRIBUTION"
SET DIR("A")="PRESS RETURN TO CONTINUE"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
GOTO DISTQ
+25 ;
+26 IF $ORDER(RCZ1(0))=""
Begin DoDot:1
+27 SET DIR(0)="EA"
SET DIR("A",1)="NO VALID LINES EXIST ON THIS ERA WHERE A DISTRIBUTION CAN BE MADE"
SET DIR("A",2)=$$WHAT(RCSCR)
SET DIR("A")="PRESS RETURN TO CONTINUE"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
GOTO DISTQ
+28 ;
+29 SET RCQUIT=0
+30 FOR
SET DIR(0)="NA^1:9999:3"
SET DIR("A")="SELECT A LINE THAT NEEDS AN ADJUSTMENT AMOUNT DISTRIBUTED: "
Begin DoDot:1
+31 SET DIR("?",1)="THE FOLLOWING LINE(S) HAVE AN ADJUSTMENT THAT CAUSED A NEGATIVE NET PAYMENT."
SET DIR("?",2)="IN ORDER TO BALANCE THE RECEIPT AND THE DEPOSIT, THESE AMOUNTS WILL NEED TO"
SET DIR("?",3)=" BE DISTRIBUTED TO OTHER LINE(S)"
SET CT=3
+32 SET Z=0
+33 FOR
SET Z=$ORDER(RCZ(Z))
if 'Z
QUIT
SET CT=CT+1
SET DIR("?",CT)=" "_$JUSTIFY(Z,8)_" "_$JUSTIFY($PIECE(RCZ(Z),U),15,2)
+34 SET DIR("?")=" "
+35 IF $ORDER(RCZ(0))=$ORDER(RCZ(""),-1)
SET DIR("B")=$ORDER(RCZ(0))
+36 WRITE !
DO ^DIR
KILL DIR
+37 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y="")
SET RCQUIT=1
SET RCDA=""
QUIT
+38 IF '$DATA(^TMP("RCDPE-EOB_WLDX",$JOB,Y))
WRITE !,"THIS LINE DOES NOT EXIST FOR THIS ERA"
WRITE !
QUIT
+39 IF '$DATA(RCZ(Y))
Begin DoDot:2
+40 IF Y'["."
IF $DATA(RCZ(Y_".001"))
IF $ORDER(RCZ(Y+1),-1)=(Y_".001")
SET Y=Y_".001"
QUIT
+41 WRITE !,$SELECT(Y["."!($ORDER(RCZ(Y))\1'=(Y\1)):"THIS LINE DOESN'T NEED AN ADJUSTMENT DISTRIBUTION",1:"PLEASE ENTER THE ENTIRE LINE # (Such as: 1.001)")
WRITE !
+42 SET Y=""
End DoDot:2
if Y=""
QUIT
+43 WRITE !," LINE #: "_+Y_" AMOUNT NEEDED TO DISTRIBUTE: "_$JUSTIFY(+RCZ(Y),"",2),!
+44 ; RCDA = the ien of the line in file 344.491
+45 ; RCDA(1) = the line # RCDA(2) = the amount to be adjusted (+)
+46 SET RCDA=$PIECE(RCZ(Y),U,2)
SET RCDA(1)=Y
SET RCQUIT=1
SET RCDA(2)=-$PIECE(RCZ(Y),U)
End DoDot:1
if RCQUIT
QUIT
+47 ;
+48 if $GET(RCDA)=""
GOTO DISTQ
+49 ;
+50 SET RCQUIT=0
+51 ;
+52 ; PRCA*4.5*303 - May miss if multiple amounts are equal, changed calculation to use RCZ2 instead of RCZ1
+53 ; Old code: S (TOT,Z)=0 F S Z=$O(RCZ1(Z)) Q:'Z S TOT=TOT+Z
+54 SET (TOT,Z)=0
FOR
SET Z=$ORDER(RCZ2(Z))
if 'Z
QUIT
SET TOT=TOT+$PIECE(RCZ2(Z),U,2)
+55 IF TOT<RCDA(2)
Begin DoDot:1
+56 SET DIR(0)="EA"
SET DIR("A",1)="THE ERA DOES NOT HAVE ENOUGH VALID PAYMENTS TO OFFSET THIS DISTRIBUTION"
SET DIR("A",2)=$$WHAT(RCSCR)
SET DIR("A")="PRESS RETURN TO CONTINUE"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
GOTO DISTQ
+57 FOR
SET DIR(0)="NA^1:9999:3"
SET DIR("A")="SELECT A LINE TO DISTRIBUTE THE ADJUSTMENT AMOUNT TO: "
Begin DoDot:1
+58 SET DIR("?",1)="THE FOLLOWING LINE(S) HAVE A NET PAYMENT THAT CAN BE USED TO OFFSET THE"
SET DIR("?",2)=" NEGATIVE NET PAYMENT FOR LINE "_RCDA(1)_" ("_$JUSTIFY(+$PIECE(RCZ(RCDA(1)),U),"",2)_"):"
SET CT=2
+59 SET Z=""
FOR
SET Z=$ORDER(RCZ1(Z),-1)
if 'Z
QUIT
SET Z0=0
FOR
SET Z0=$ORDER(RCZ1(Z,Z0))
if 'Z0
QUIT
SET CT=CT+1
SET DIR("?",CT)=" "_$JUSTIFY(Z0,8)_" "_$JUSTIFY(+Z,15,2)_$SELECT($PIECE(RCZ1(Z,Z0),U,2):" On hold exists",1:"")
+60 SET DIR("?")=" "
+61 IF $ORDER(RCZ2(0))=$ORDER(RCZ2(""),-1)
SET DIR("B")=$ORDER(RCZ2(0))
+62 WRITE !
DO ^DIR
KILL DIR
+63 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y="")
SET RCQUIT=1
SET RCDA1=""
QUIT
+64 IF '$DATA(^TMP("RCDPE-EOB_WLDX",$JOB,Y))
WRITE !,"THIS LINE DOES NOT EXIST FOR THIS ERA"
WRITE !
QUIT
+65 IF '$DATA(RCZ2(Y))
Begin DoDot:2
+66 IF Y'["."
IF $DATA(RCZ2(Y_".001"))
IF $ORDER(RCZ2(Y+1),-1)=(Y_".001")
SET Y=Y_".001"
QUIT
+67 IF Y'["."
IF $ORDER(RCZ2(Y))\1'=Y
SET Y=Y_"."
+68 WRITE !,$SELECT(Y[".":"THIS LINE CANNOT BE USED FOR AN ADJUSTMENT DISTRIBUTION",1:"PLEASE ENTER THE ENTIRE LINE # (Such as: 1.001)")
WRITE !
+69 SET Y=""
End DoDot:2
if Y=""
QUIT
+70 ; prca276 - next few lines represent the a fix to prevent distributions agains collected/closed claims (claim balance = zero dollars)
+71 ;distributions should only occur on line items that have specific payments against active claims
+72 ; get line item sequence # off the VIEW order before accessing the scratchpad
SET RCZZ1=$PIECE(^TMP("RCDPE-EOB_WLDX",$JOB,Y),U,2)
+73 ;identify if non-specific payment adjustments exist
SET (RCZZ2,RCNONSP)=0
FOR
SET RCZZ2=$ORDER(^RCY(344.49,RCSCR,1,RCZZ1,1,RCZZ2))
if 'RCZZ2
QUIT
if RCNONSP
QUIT
SET RCADJSTR=$GET(^(RCZZ2,0))
SET RCNONSP=$SELECT($PIECE(RCADJSTR,U,2)=3:1,$PIECE(RCADJSTR,U,2)=5:1,1:0)
+74 ; do not evaluate claim status for non-specific payment adjustments
+75 ; or distributions to non-VistA claims - PRCA*4.5*326
+76 ; PRCA*4.5*326
IF 'RCNONSP
IF $PIECE(^RCY(344.49,RCSCR,1,RCZZ1,0),U,7)
Begin DoDot:2
+77 SET RCACTIVE=$$GET1^DIQ(430,$PIECE(^RCY(344.49,RCSCR,1,RCZZ1,0),U,7),8)
+78 IF (RCACTIVE'="ACTIVE")&(RCACTIVE'="OPEN")
SET RCACTIVE=0
WRITE !,"THIS IS NOT AN ACTIVE BILL !",!,"CANNOT PERFORM DISTRIBUTION TO THIS CLAIM",!
QUIT
+79 SET RCACTIVE=1
End DoDot:2
if 'RCACTIVE
QUIT
+80 IF $PIECE(RCZ2(Y),U,3)
WRITE !,"Warning - on-hold exists for this claim",!
+81 WRITE !," LINE #: "_+Y_" LINE BALANCE: "_$JUSTIFY(+$PIECE(RCZ2(Y),U,2),"",2),!
+82 ; RCDA1 = the ien of the line in file 344.491
+83 ; RCDA1(1) = the line # in the display
+84 SET RCDA1(1)=Y
SET RCDA1=+$GET(RCZ2(Y))
SET RCQUIT=1
+85 SET Z=$ORDER(^RCY(344.49,RCSCR,1,"B",RCDA1(1)\1,0))
+86 SET RCADJ=0
+87 IF $PIECE($GET(^RCY(344.49,RCSCR,1,Z,0)),U,2)["**ADJ"
SET RCADJ=1
WRITE !,"THE LINE SELECTED IS AN ADDITIONAL PAYMENT LINE, NOT SPECIFIC TO A CLAIM",!,"THE AMT WILL BE DISTRIBUTED, BUT A DECREASE ADJUSTMENT WILL NOT BE PERFORMED",!
End DoDot:1
if RCQUIT
QUIT
+88 ;
+89 if '$GET(RCDA1)
GOTO DISTQ
+90 ;
+91 SET DIR("B")=$SELECT(RCDA(2)<$PIECE(RCZ2(RCDA1(1)),U,2):$JUSTIFY(RCDA(2),"",2),1:$JUSTIFY($PIECE(RCZ2(+RCDA1(1)),U,2),"",2))
+92 SET DIR(0)="NA^.01:"_DIR("B")_":2"
SET DIR("A")="ADJUSTMENT AMOUNT TO DISTRIBUTE: "
+93 SET DIR("?",1)="THIS IS THE AMOUNT OF THE ADJUSTMENT THAT SHOULD BE APPLIED TO THIS"
SET DIR("?")="PAYMENT LINE. THE AMT ENTERED MUST BE BETWEEN .01 AND "_$JUSTIFY(DIR("B"),"",2)
+94 DO ^DIR
KILL DIR
+95 ;
+96 IF $DATA(DUOUT)!$DATA(DTOUT)!'Y
Begin DoDot:1
+97 SET DIR(0)="EA"
SET DIR("A",1)="NO AMOUNT WAS ENTERED - TRY AGAIN LATER"
SET DIR("A")="PRESS RETURN TO CONTINUE "
DO ^DIR
KILL DIR
End DoDot:1
GOTO DISTQ
+98 SET RCAMT=$JUSTIFY(Y,"",2)
+99 ;
+100 DO ^DIR
KILL DIR
+101 IF $DATA(DUOUT)!$DATA(DTOUT)
Begin DoDot:1
+102 SET DIR(0)="EA"
SET DIR("A")="USER ABORT - PRESS RETURN TO CONTINUE "
DO ^DIR
KILL DIR
End DoDot:1
GOTO DISTQ
+103 ;
+104 SET Y=""
+105 IF 'RCADJ
Begin DoDot:1
+106 NEW Z,RCA
+107 SET RCA=0
SET Z1=+$PIECE($GET(^TMP("RCDPE-EOB_WLDX",$JOB,RCDA(1)\1)),U,2)
SET Z=$GET(^RCY(344.49,RCSCR,1,Z1,0))
SET RCA("#")=+$PIECE($PIECE(Z,U,2),"**ADJ",2)
+108 IF $PIECE(Z,U,2)["**ADJ"
Begin DoDot:2
+109 SET RCA=1
+110 SET RCA("REF")=$SELECT(RCA("#"):$PIECE($GET(^RCY(344.4,RCSCR,2,RCA("#"),0)),U),1:$PIECE(Z,U,9))
End DoDot:2
+111 SET Z=$SELECT(RCA:RCA("#"),1:$GET(^RCY(344.49,RCSCR,1,RCDA,0)))
+112 SET DIR(0)="FAO^1:60"
SET DIR("A")=" > "
SET DIR("A",1)="DECREASE ADJ COMMENT (1-60 CHARACTERS): "
+113 SET DIR("B")="RETRACTED FOR "
+114 SET DIR("B")=DIR("B")_$SELECT(RCA:"ERA ADJ #"_Z_" Ref: "_RCA("REF"),1:"CLAIM "_$SELECT($PIECE(Z,U,2)'="":$PIECE(Z,U,2),1:"UNKNOWN"))
+115 IF $LENGTH(DIR("B"))>60
SET DIR("B")=$EXTRACT(DIR("B"),1,60)
+116 DO ^DIR
KILL DIR
+117 ;
+118 IF $DATA(DUOUT)!$DATA(DTOUT)
Begin DoDot:2
+119 KILL RCDA
+120 SET DIR(0)="EA"
SET DIR("A")="USER ABORT - PRESS RETURN TO CONTINUE "
DO ^DIR
KILL DIR
End DoDot:2
QUIT
End DoDot:1
if '$DATA(RCDA)
GOTO DISTQ
+121 ;
+122 DO DISTADJ^RCDPEWL4(RCDA,RCDA1,RCAMT,Y)
+123 ;
DISTQ SET VALMBCK="R"
+1 QUIT
+2 ;
REFRESH ;EP - Protocol action - RCDPE EOB WORKLIST REFRESH
+1 ; Refresh the entry in file 344.49 to remove all user adjustments
+2 NEW DA,DIK,DIR,RCQUIT,RCREDEF,X,Y,Z,Z0
+3 DO FULL^VALM1
+4 ; PRCA*4.5*318 Added security key check
IF '$DATA(^XUSEC("RCDPEPP",DUZ))
Begin DoDot:1
+5 WRITE !!,"This action can only be taken by users that have the RCDPEPP security key.",!
+6 DO PAUSE^VALM1
+7 SET VALMBCK="R"
End DoDot:1
QUIT
+8 ;prca*4.5*298 auto-posted ERAs cannot enter REFRESH SCRATCHPAD action
IF $SELECT($PIECE($GET(^RCY(344.4,RCSCR,4)),U,2)]"":1,1:0)
DO NOEDIT^RCDPEWLP
GOTO REFQ
+9 IF $GET(RCSCR("NOEDIT"))
DO NOEDIT^RCDPEWL
GOTO REFQ
+10 ; prca*4.5*298 per patch requirements, keep code related to creating/maintaining
+11 ; batches but just remove from execution
+12 ;I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL G REFQ ;prca*4.5*298
+13 SET DIR(0)="YA"
+14 SET DIR("A",1)="THIS ACTION WILL DELETE AND REBUILD THIS EEOB WORKLIST SCRATCH PAD ENTRY"
SET DIR("A",2)="ALL EDITS/SPLITS/DISTRIBUTE ADJUSTMENTS ENTERED FOR THIS ERA WILL BE ERASED"
+15 SET DIR("A",3)="AND ALL ENTRIES MARKED AS MANUALLY VERIFIED WILL BE UNMARKED"
SET DIR("A",4)=" "
+16 SET DIR("A")="ARE YOU SURE YOU WANT TO DO THIS?: "
+17 WRITE !
DO ^DIR
KILL DIR
+18 IF Y'=1
GOTO REFQ
+19 ; prca*4.5*298 per patch requirements, keep code related to creating/maintaining
+20 ; batches but just remove from execution
+21 ;I $O(^RCY(344.49,RCSCR,3,0)) S RCQUIT=0 D I RCQUIT G REFQ
+22 ;. S DIR(0)="YA",DIR("A")="DO YOU WANT TO REDEFINE YOUR BATCHES TOO?: ",DIR("B")="NO" W ! D ^DIR K DIR
+23 ;. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
+24 ;. S RCREDEF=+Y
+25 ;. K ^TMP($J,"BATCHES")
+26 ;. S Z=0 F S Z=$O(^RCY(344.49,RCSCR,3,Z)) Q:'Z S Z0=$G(^(Z,0)) D
+27 ;.. I RCREDEF S DA=Z,DA(1)=RCSCR,DIK="^RCY(344.49,"_DA(1)_",3," D ^DIK Q
+28 ;.. S ^TMP($J,"BATCHES",+$P(Z0,U,6),$P(Z0,U,7))=+Z0_U_$P(Z0,U,8)
+29 ;. I 'RCREDEF S ^TMP($J,"BATCHES")=+$O(^TMP($J,"BATCHES",0))
+30 ;. I RCREDEF D SETBATCH^RCDPEWLB(RCSCR)
+31 DO ADDLINES^RCDPEWLA(RCSCR)
+32 DO BLD^RCDPEWL1($GET(^TMP($JOB,"RC_SORTPARM")))
+33 KILL ^TMP($JOB,"BATCHES")
REFQ SET VALMBG=1
SET VALMBCK="R"
+1 QUIT
+2 ;
WHAT(RCSCR) ; Text for what to do if not enough funds found for dist adj
+1 QUIT $SELECT($ORDER(^RCY(344.31,"AERA",+RCSCR,0)):"THIS ERA MUST BE MOVED TO SUSPENSE",1:"THIS ERA'S RECEIPT MUST BE ENTERED MANUALLY")
+2 ;
ADJUST ; Allow entry into increase/decrease adjustment functions
+1 NEW DIR,X,Y,RCTYP,RCY,DIC
+2 DO FULL^VALM1
+3 ;
+4 IF $GET(RCSCR("NOEDIT"))=2
DO NOTAV^RCDPEWL2
GOTO ADJUSTQ
+5 ; PRCA*4.5*276 - check for authorized user
+6 IF '$DATA(^XUSEC("PRCADJ",DUZ))
Begin DoDot:1
+7 SET DIR(0)="EA"
SET DIR("A",1)="The Adjust (Inc/Dec) Action is locked."
+8 SET DIR("A",2)="Please speak to your Supervisor to request the key."
+9 SET DIR("A")="PRESS RETURN TO CONTINUE"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+10 ; PRCA*4.5*276 - end of changes
+11 ;
+12 SET DIR(0)="SA^D:DECREASE ADJUSTMENT;I:INCREASE ADJUSTMENT"
SET DIR("B")="DECREASE ADJUSTMENT"
SET DIR("A")="TYPE OF ADJUSTMENT: "
+13 WRITE !
DO ^DIR
KILL DIR
+14 MERGE ^TMP("RC_SAVE_TMP",$JOB)=^TMP($JOB)
+15 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y="")
GOTO ADJUSTQ
+16 ;
+17 SET RCTYP=$SELECT(Y="D":"DECREASE",1:"INCREASE")
+18 FOR
SET RCY=$$GETABILL^RCBEUBIL
if RCY<0!(RCY'<1)
QUIT
+19 if RCY<1
GOTO ADJUSTQ
+20 DO ADJUST^RCBEADJ(RCTYP,RCY_";"_RCSCR)
+21 IF $DATA(^TMP("RC_BILL",$JOB,RCY))
Begin DoDot:1
+22 DO UPDBAL(RCY)
+23 WRITE !,"Claim balance is now: ",$JUSTIFY(+$PIECE($$BILL^RCJIBFN2(RCY),U,3),"",2)
End DoDot:1
+24 ;
ADJUSTQ DO RESTMP
+1 DO RET^RCDPEWL2
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
RESTMP ;
+1 IF $DATA(^TMP("RC_SAVE_TMP",$JOB))
MERGE ^TMP($JOB)=^TMP("RC_SAVE_TMP",$JOB)
KILL ^TMP("RC_SAVE_TMP")
+2 QUIT
+3 ;
UPDBAL(RCY) ; Updates the claim balance if bill exists in list
+1 ; RCY = ien of bill in file 430
+2 ;
+3 NEW X,Y,Z,Z0,Z1
+4 SET Z0=$JUSTIFY(+$PIECE($$BILL^RCJIBFN2(RCY),U,3),"",2)
+5 SET Z=0
FOR
SET Z=$ORDER(^TMP("RC_BILL",$JOB,RCY,Z))
if 'Z
QUIT
Begin DoDot:1
+6 SET X=+$GET(^TMP("RCDPE-EOB_WLDX",$JOB,Z))
+7 if 'X
QUIT
+8 SET Y=$GET(^TMP("RCDPE-EOB_WL",$JOB,X+1,0))
+9 IF Y["Claim Bal: "
SET Z1=$PIECE(Y,"Claim Bal: ")_"Claim Bal: "_Z0_$GET(^TMP("RC_BILL",$JOB,RCY,Z))
SET ^TMP("RCDPE-EOB_WL",$JOB,X+1,0)=Z1
End DoDot:1
+10 QUIT
+11 ;
