RCDPEAR3 ;AITC/CJE - ERA Unmatched Aging Report ;
;;4.5;Accounts Receivable;**321**;;Build 48
;Per VA Directive 6402, this routine should not be modified.
Q
;
; PRCA*4.5*321 overflow routine for and RCDPEAR2
; SELPAY and RLOAD moved from RCDPEAR1 to meet SAC size limit
SELPAY(RCRESPYR,RCJOB,RCPAY) ;localize the payer filters for header display
; Input:
; RCRESPYR (pass-by-val/required) - payer filter response indicator (2=ALL, 3=SPECIFIC)
; RCJOB - job number to access the populated temporary global array in case report was tasked to run
; Output:
; RCPAY (pass-by-ref/required) - local array of payers e.g. RCPAY="ALL", RCPAY(1)="Aetna",
; or RCPAY="start payer = end payer"
N CNT,I
I RCRESPYR=2 S RCPAY="ALL" Q
S:RCJOB="" RCJOB=$J ; RCJOB should not be null
I RCRESPYR=3 D Q
.S CNT=0
.F S CNT=$O(^TMP("RCSELPAY",RCJOB,CNT)) Q:'CNT D
..S RCPAY(CNT)=^TMP("RCSELPAY",RCJOB,CNT)
; RCRESPYR indicates a range of payers
S I=$O(^TMP("RCSELPAY",RCJOB,"")),RCPAY=^(I)_" - "
S I=$O(^TMP("RCSELPAY",RCJOB,""),-1),RCPAY=RCPAY_^(I)
Q
;
RLOAD(FILE) ; PRCA*4.5*284 - Load Payer temp global AFTER queued job starts
; Load Selected payers from local array end exit
; Input: FILE to load payers from (344.31 passed from RCDPEAR2)
; Output: ^TMP("RCPAYER") and ^TMP("RCSELPAY") arrays
;
I +RCRESPYR=3 M ^TMP("RCSELPAY",$J)=RCPYRLST Q
N CNT,INDX,NUM,RCINSF,RCINST,RCPAY
;
; Load ALL payers and exit
I +RCRESPYR=2 D Q
.S CNT=0,RCPAY="" F S RCPAY=$O(^RCY(FILE,"C",RCPAY)) Q:RCPAY="" S CNT=CNT+1,^TMP("RCSELPAY",$J,CNT)=RCPAY
;
; Range of Payers
; Build list of available stations
K ^TMP("RCPAYER",$J) ; Clear residual list data
S CNT=0,RCPAY=""
F S RCPAY=$O(^RCY(FILE,"C",RCPAY)) Q:RCPAY="" S CNT=CNT+1,^TMP("RCPAYER",$J,CNT)=RCPAY,^TMP("RCPAYER",$J,"B",RCPAY,CNT)=""
;
S RCINSF=$P(RCRESPYR,"^",2),RCINST=$P(RCRESPYR,"^",3),INDX=1
F S RCINSF=$O(^TMP("RCPAYER",$J,"B",RCINSF)) Q:RCINSF="" Q:RCINSF]RCINST D
.S NUM=$O(^TMP("RCPAYER",$J,"B",RCINSF,""))
.S ^TMP("RCSELPAY",$J,INDX)=$G(^TMP("RCPAYER",$J,NUM)),INDX=INDX+1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEAR3 2157 printed Sep 23, 2025@19:20:27 Page 2
RCDPEAR3 ;AITC/CJE - ERA Unmatched Aging Report ;
+1 ;;4.5;Accounts Receivable;**321**;;Build 48
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; PRCA*4.5*321 overflow routine for and RCDPEAR2
+6 ; SELPAY and RLOAD moved from RCDPEAR1 to meet SAC size limit
SELPAY(RCRESPYR,RCJOB,RCPAY) ;localize the payer filters for header display
+1 ; Input:
+2 ; RCRESPYR (pass-by-val/required) - payer filter response indicator (2=ALL, 3=SPECIFIC)
+3 ; RCJOB - job number to access the populated temporary global array in case report was tasked to run
+4 ; Output:
+5 ; RCPAY (pass-by-ref/required) - local array of payers e.g. RCPAY="ALL", RCPAY(1)="Aetna",
+6 ; or RCPAY="start payer = end payer"
+7 NEW CNT,I
+8 IF RCRESPYR=2
SET RCPAY="ALL"
QUIT
+9 ; RCJOB should not be null
if RCJOB=""
SET RCJOB=$JOB
+10 IF RCRESPYR=3
Begin DoDot:1
+11 SET CNT=0
+12 FOR
SET CNT=$ORDER(^TMP("RCSELPAY",RCJOB,CNT))
if 'CNT
QUIT
Begin DoDot:2
+13 SET RCPAY(CNT)=^TMP("RCSELPAY",RCJOB,CNT)
End DoDot:2
End DoDot:1
QUIT
+14 ; RCRESPYR indicates a range of payers
+15 SET I=$ORDER(^TMP("RCSELPAY",RCJOB,""))
SET RCPAY=^(I)_" - "
+16 SET I=$ORDER(^TMP("RCSELPAY",RCJOB,""),-1)
SET RCPAY=RCPAY_^(I)
+17 QUIT
+18 ;
RLOAD(FILE) ; PRCA*4.5*284 - Load Payer temp global AFTER queued job starts
+1 ; Load Selected payers from local array end exit
+2 ; Input: FILE to load payers from (344.31 passed from RCDPEAR2)
+3 ; Output: ^TMP("RCPAYER") and ^TMP("RCSELPAY") arrays
+4 ;
+5 IF +RCRESPYR=3
MERGE ^TMP("RCSELPAY",$JOB)=RCPYRLST
QUIT
+6 NEW CNT,INDX,NUM,RCINSF,RCINST,RCPAY
+7 ;
+8 ; Load ALL payers and exit
+9 IF +RCRESPYR=2
Begin DoDot:1
+10 SET CNT=0
SET RCPAY=""
FOR
SET RCPAY=$ORDER(^RCY(FILE,"C",RCPAY))
if RCPAY=""
QUIT
SET CNT=CNT+1
SET ^TMP("RCSELPAY",$JOB,CNT)=RCPAY
End DoDot:1
QUIT
+11 ;
+12 ; Range of Payers
+13 ; Build list of available stations
+14 ; Clear residual list data
KILL ^TMP("RCPAYER",$JOB)
+15 SET CNT=0
SET RCPAY=""
+16 FOR
SET RCPAY=$ORDER(^RCY(FILE,"C",RCPAY))
if RCPAY=""
QUIT
SET CNT=CNT+1
SET ^TMP("RCPAYER",$JOB,CNT)=RCPAY
SET ^TMP("RCPAYER",$JOB,"B",RCPAY,CNT)=""
+17 ;
+18 SET RCINSF=$PIECE(RCRESPYR,"^",2)
SET RCINST=$PIECE(RCRESPYR,"^",3)
SET INDX=1
+19 FOR
SET RCINSF=$ORDER(^TMP("RCPAYER",$JOB,"B",RCINSF))
if RCINSF=""
QUIT
if RCINSF]RCINST
QUIT
Begin DoDot:1
+20 SET NUM=$ORDER(^TMP("RCPAYER",$JOB,"B",RCINSF,""))
+21 SET ^TMP("RCSELPAY",$JOB,INDX)=$GET(^TMP("RCPAYER",$JOB,NUM))
SET INDX=INDX+1
End DoDot:1
+22 QUIT
+23 ;
