- 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 Feb 18, 2025@23:12:08 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 ;