RCBEADJ1 ;ALB/PJH - PENDING PAYMENTS ;24-FEB-03
;;4.5;Accounts Receivable;**173,276,321,326,332**;Mar 20, 1995;Build 40
;;Per VA Directive 6402, this routine should not be modified.
Q
WARN(RCBILLDA) ; Display warning if pending payments exist EP ^RCBEADJ
; Input - RCBILLDA - Pointer #430 - required
; Output - None - output to screen only
;
; Check for valid input
Q:'$G(RCBILLDA)
;
N DEBTOR,RCAMT,RCEOB,RCERA,RCLINE,RCPAID,RCPEND,RCRCPT,RCRCPTN,RCSUB,RCTOT,RCTRACE,RCTRANDA,RCZ,RCZL
; Set DEBTOR value
S DEBTOR=RCBILLDA_";PRCA(430,"
; Check for unprocessed receipts
S RCPEND=$$PENDPAY^RCDPURET(DEBTOR)
; Extract receipt numbers and amounts paid on individual lines for pending receipts
S RCRCPT=0
F S RCRCPT=$O(^TMP($J,"RCDPUREC","PP",RCRCPT)) Q:'RCRCPT D
. S RCRCPTN=$$GET1^DIQ(344,RCRCPT_",",.01) Q:RCRCPTN=""
. S RCPEND("R",RCRCPTN)=0
. S RCTRANDA=0
. F S RCTRANDA=$O(^TMP($J,"RCDPUREC","PP",RCRCPT,RCTRANDA)) Q:'RCTRANDA D
. . S RCAMT=$P($G(^TMP($J,"RCDPUREC","PP",RCRCPT,RCTRANDA)),U,4) Q:+RCAMT=0
. . ; Save paid amount for this claim on this receipt
. . S RCPEND("R",RCRCPTN)=RCPEND("R",RCRCPTN)+RCAMT
. . ; Get trace number for ERA
. . S RCERA=$$GET1^DIQ(344,RCRCPT_",",.18,"I")
. . S RCTRACE=$S(RCERA:$$GET1^DIQ(344.4,RCERA_",",.02,"I"),1:"No Trace Number")
. . ; Save trace number
. . S RCPEND("R",RCRCPTN,"T")=RCTRACE
; Clear ^TMP array returned by $$PENDPAY
K ^TMP($J,"RCDPUREC","PP")
; Find EEOB's for this claim
S RCEOB=0
F S RCEOB=$O(^IBM(361.1,"B",RCBILLDA,RCEOB)) Q:'RCEOB D
. ;Find ERAs for this EOB - may be multiple
. S RCERA=0
. F S RCERA=$O(^RCY(344.4,"ADET",RCEOB,RCERA)) Q:'RCERA D
. . ; Ignore ERA which already has a receipt - processed or otherwise
. . I $$GET1^DIQ(344.4,RCERA_",",.08,"I") Q
. . ; Get ERA lines for this EOB
. . S RCLINE=0,RCTOT=0
. . F S RCLINE=$O(^RCY(344.4,"ADET",RCEOB,RCERA,RCLINE)) Q:'RCLINE D
. . . ; Get paid amount from ERA line
. . . S RCPAID=$$GET1^DIQ(344.41,RCLINE_","_RCERA_",",.03)
. . . ; Ignore zero lines
. . . Q:'RCPAID
. . . ; If no scratchpad use paid amount from ERA - does not take into account ERA level adjustments
. . . I '$D(^RCY(344.49,RCERA)) S RCTOT=RCTOT+RCPAID Q
. . . ; Find ERA line in scratchpad
. . . S RCZL=$$FIND(RCERA,RCLINE) Q:'RCZL
. . . ; If scratchpad exists scan B index for split lines(344.49 is DINUM with 344.4)
. . . S RCSUB=RCZL
. . . F S RCSUB=$O(^RCY(344.49,RCERA,1,"B",RCSUB)) Q:(RCSUB\1)'=RCZL D
. . . . S RCZ=$O(^RCY(344.49,RCERA,1,"B",RCSUB,"")) Q:'RCZ
. . . . ; Check AR BILL is for this claim
. . . . Q:$$GET1^DIQ(344.491,RCZ_","_RCERA_",",.07,"I")'=RCBILLDA
. . . . ; Add AMOUNT TO POST ON RECEIPT to pending total - should resolve reversals
. . . . S RCTOT=RCTOT+$$GET1^DIQ(344.491,RCZ_","_RCERA_",",.03)
. . ; If claim total for the ERA is zero do not save trace number and paid amount
. . Q:RCTOT=0
. . ; Otherwise get trace number
. . S RCTRACE=$$GET1^DIQ(344.4,RCERA_",",.02,"I")
. . S RCPEND=RCPEND+RCTOT
. . ; Save totals by ERA
. . S RCPEND("E",RCERA)=RCTOT,RCPEND("E",RCERA,"T")=$S(RCTRACE'="":RCTRACE,1:"No Trace Number")
Q:'RCPEND
W !!,"Warning - Pending Payments of $"_$J(RCPEND,0,2)_" exist."
; List unprocessed receipts
S RCRCPTN=""
F S RCRCPTN=$O(RCPEND("R",RCRCPTN)) Q:RCRCPTN="" W !,"Rcpt: ",RCRCPTN,?16,$J("$"_$J(RCPEND("R",RCRCPTN),0,2),11),?29,$G(RCPEND("R",RCRCPTN,"T"))
; List unprocessed EOB
S RCERA=""
F S RCERA=$O(RCPEND("E",RCERA)) Q:'RCERA W !,"ERA : ",RCERA,?16,$J("$"_$J(RCPEND("E",RCERA),0,2),11),?29,$G(RCPEND("E",RCERA,"T"))
Q
;
FIND(RCERA,RCLINE) ; Search ORIGINAL ERA SEQUENCES for this line
; Input RCERA - Scratchpad IEN
; RCLINE - ERA line to find
; Output RET - Scratchpad line number
;
N DA,ORIG,RCSUB,RET
S RCSUB=0,RET=0
F S RCSUB=$O(^RCY(344.49,RCERA,1,"ASEQ",RCSUB)) Q:RET Q:'RCSUB D
. S DA=$O(^RCY(344.49,RCERA,1,"ASEQ",RCSUB,"")) Q:'DA
. ;Get Original sequences
. S ORIG=$$GET1^DIQ(344.491,DA_","_RCERA_",",.09) Q:ORIG=""
. ;Check if scratchpad line is for original ERA line
. S ORIG=","_ORIG_","
. S:$F(ORIG,","_RCLINE_",") RET=RCSUB
Q RET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCBEADJ1 4198 printed Apr 09, 2024@20:44:43 Page 2
RCBEADJ1 ;ALB/PJH - PENDING PAYMENTS ;24-FEB-03
+1 ;;4.5;Accounts Receivable;**173,276,321,326,332**;Mar 20, 1995;Build 40
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
WARN(RCBILLDA) ; Display warning if pending payments exist EP ^RCBEADJ
+1 ; Input - RCBILLDA - Pointer #430 - required
+2 ; Output - None - output to screen only
+3 ;
+4 ; Check for valid input
+5 if '$GET(RCBILLDA)
QUIT
+6 ;
+7 NEW DEBTOR,RCAMT,RCEOB,RCERA,RCLINE,RCPAID,RCPEND,RCRCPT,RCRCPTN,RCSUB,RCTOT,RCTRACE,RCTRANDA,RCZ,RCZL
+8 ; Set DEBTOR value
+9 SET DEBTOR=RCBILLDA_";PRCA(430,"
+10 ; Check for unprocessed receipts
+11 SET RCPEND=$$PENDPAY^RCDPURET(DEBTOR)
+12 ; Extract receipt numbers and amounts paid on individual lines for pending receipts
+13 SET RCRCPT=0
+14 FOR
SET RCRCPT=$ORDER(^TMP($JOB,"RCDPUREC","PP",RCRCPT))
if 'RCRCPT
QUIT
Begin DoDot:1
+15 SET RCRCPTN=$$GET1^DIQ(344,RCRCPT_",",.01)
if RCRCPTN=""
QUIT
+16 SET RCPEND("R",RCRCPTN)=0
+17 SET RCTRANDA=0
+18 FOR
SET RCTRANDA=$ORDER(^TMP($JOB,"RCDPUREC","PP",RCRCPT,RCTRANDA))
if 'RCTRANDA
QUIT
Begin DoDot:2
+19 SET RCAMT=$PIECE($GET(^TMP($JOB,"RCDPUREC","PP",RCRCPT,RCTRANDA)),U,4)
if +RCAMT=0
QUIT
+20 ; Save paid amount for this claim on this receipt
+21 SET RCPEND("R",RCRCPTN)=RCPEND("R",RCRCPTN)+RCAMT
+22 ; Get trace number for ERA
+23 SET RCERA=$$GET1^DIQ(344,RCRCPT_",",.18,"I")
+24 SET RCTRACE=$SELECT(RCERA:$$GET1^DIQ(344.4,RCERA_",",.02,"I"),1:"No Trace Number")
+25 ; Save trace number
+26 SET RCPEND("R",RCRCPTN,"T")=RCTRACE
End DoDot:2
End DoDot:1
+27 ; Clear ^TMP array returned by $$PENDPAY
+28 KILL ^TMP($JOB,"RCDPUREC","PP")
+29 ; Find EEOB's for this claim
+30 SET RCEOB=0
+31 FOR
SET RCEOB=$ORDER(^IBM(361.1,"B",RCBILLDA,RCEOB))
if 'RCEOB
QUIT
Begin DoDot:1
+32 ;Find ERAs for this EOB - may be multiple
+33 SET RCERA=0
+34 FOR
SET RCERA=$ORDER(^RCY(344.4,"ADET",RCEOB,RCERA))
if 'RCERA
QUIT
Begin DoDot:2
+35 ; Ignore ERA which already has a receipt - processed or otherwise
+36 IF $$GET1^DIQ(344.4,RCERA_",",.08,"I")
QUIT
+37 ; Get ERA lines for this EOB
+38 SET RCLINE=0
SET RCTOT=0
+39 FOR
SET RCLINE=$ORDER(^RCY(344.4,"ADET",RCEOB,RCERA,RCLINE))
if 'RCLINE
QUIT
Begin DoDot:3
+40 ; Get paid amount from ERA line
+41 SET RCPAID=$$GET1^DIQ(344.41,RCLINE_","_RCERA_",",.03)
+42 ; Ignore zero lines
+43 if 'RCPAID
QUIT
+44 ; If no scratchpad use paid amount from ERA - does not take into account ERA level adjustments
+45 IF '$DATA(^RCY(344.49,RCERA))
SET RCTOT=RCTOT+RCPAID
QUIT
+46 ; Find ERA line in scratchpad
+47 SET RCZL=$$FIND(RCERA,RCLINE)
if 'RCZL
QUIT
+48 ; If scratchpad exists scan B index for split lines(344.49 is DINUM with 344.4)
+49 SET RCSUB=RCZL
+50 FOR
SET RCSUB=$ORDER(^RCY(344.49,RCERA,1,"B",RCSUB))
if (RCSUB\1)'=RCZL
QUIT
Begin DoDot:4
+51 SET RCZ=$ORDER(^RCY(344.49,RCERA,1,"B",RCSUB,""))
if 'RCZ
QUIT
+52 ; Check AR BILL is for this claim
+53 if $$GET1^DIQ(344.491,RCZ_","_RCERA_",",.07,"I")'=RCBILLDA
QUIT
+54 ; Add AMOUNT TO POST ON RECEIPT to pending total - should resolve reversals
+55 SET RCTOT=RCTOT+$$GET1^DIQ(344.491,RCZ_","_RCERA_",",.03)
End DoDot:4
End DoDot:3
+56 ; If claim total for the ERA is zero do not save trace number and paid amount
+57 if RCTOT=0
QUIT
+58 ; Otherwise get trace number
+59 SET RCTRACE=$$GET1^DIQ(344.4,RCERA_",",.02,"I")
+60 SET RCPEND=RCPEND+RCTOT
+61 ; Save totals by ERA
+62 SET RCPEND("E",RCERA)=RCTOT
SET RCPEND("E",RCERA,"T")=$SELECT(RCTRACE'="":RCTRACE,1:"No Trace Number")
End DoDot:2
End DoDot:1
+63 if 'RCPEND
QUIT
+64 WRITE !!,"Warning - Pending Payments of $"_$JUSTIFY(RCPEND,0,2)_" exist."
+65 ; List unprocessed receipts
+66 SET RCRCPTN=""
+67 FOR
SET RCRCPTN=$ORDER(RCPEND("R",RCRCPTN))
if RCRCPTN=""
QUIT
WRITE !,"Rcpt: ",RCRCPTN,?16,$JUSTIFY("$"_$JUSTIFY(RCPEND("R",RCRCPTN),0,2),11),?29,$GET(RCPEND("R",RCRCPTN,"T"))
+68 ; List unprocessed EOB
+69 SET RCERA=""
+70 FOR
SET RCERA=$ORDER(RCPEND("E",RCERA))
if 'RCERA
QUIT
WRITE !,"ERA : ",RCERA,?16,$JUSTIFY("$"_$JUSTIFY(RCPEND("E",RCERA),0,2),11),?29,$GET(RCPEND("E",RCERA,"T"))
+71 QUIT
+72 ;
FIND(RCERA,RCLINE) ; Search ORIGINAL ERA SEQUENCES for this line
+1 ; Input RCERA - Scratchpad IEN
+2 ; RCLINE - ERA line to find
+3 ; Output RET - Scratchpad line number
+4 ;
+5 NEW DA,ORIG,RCSUB,RET
+6 SET RCSUB=0
SET RET=0
+7 FOR
SET RCSUB=$ORDER(^RCY(344.49,RCERA,1,"ASEQ",RCSUB))
if RET
QUIT
if 'RCSUB
QUIT
Begin DoDot:1
+8 SET DA=$ORDER(^RCY(344.49,RCERA,1,"ASEQ",RCSUB,""))
if 'DA
QUIT
+9 ;Get Original sequences
+10 SET ORIG=$$GET1^DIQ(344.491,DA_","_RCERA_",",.09)
if ORIG=""
QUIT
+11 ;Check if scratchpad line is for original ERA line
+12 SET ORIG=","_ORIG_","
+13 if $FIND(ORIG,","_RCLINE_",")
SET RET=RCSUB
End DoDot:1
+14 QUIT RET
