- 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 Feb 18, 2025@23:09:01 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