RCDPEAR1 ;ALB/TMK/PJH - ERA Unmatched Aging Report (file #344.4) ;Dec 20, 2014@18:41:35
;;4.5;Accounts Receivable;**173,269,276,284,293,298,321,326,371,409,432**;Mar 20, 1995;Build 16
;Per VA Directive 6402, this routine should not be modified.
Q
;
; PRCA*4.5*298 routine completely refactored
EN1 ; entry point - ERA Unmatched Aging Report [RCDPE ERA AGING REPORT]
; data from ELECTRONIC REMITTANCE ADVICE file (#344.4)
N POP,RCDADJ,RCDISPTY,RCDT,RCDTRNG,RCHDR,RCJOB,RCLNCNT,RCLSTMGR,RCOUT ;PRCA*4.5*409 Added POP,RCADJ
N RCPAR,RCPAY,RCPGNUM,RCPYRLST,RCSTOP,RCTMPND,RCTYPE,RCXCLUDE,RCZROBAL,VAUTD,XX,Y
;
; RCDADJ - Display Adjustment/Code info flag ;PRCA*4.5*409 Added line
; RCDISPTY - Display type (Excel)
; RCDTRNG - Selected date range
; RCDT("BEG") - Start date, RCDT("END") - end date
; RCHDR - Header array
; RCLSTMGR - list manager flag
; RCDTRNG - "1^start date^end date"
; RCXCLUDE("CHAMPVA") - boolean, exclude CHAMPVA
; RCXCLUDE("TRICARE") - boolean, exclude TriCare
; RCZROBAL - Zero balance flag
; VAUTD - Division information
; RCTYPE - MEDICAL/PHARMACY/TRICARE/CHAMPVA/ALL = M/P/T/C/A
; RCPAY - S=SELECTED, R=RANGE, A=ALL
; (Selected or range - payers stored in ^TMP(""RCDPEU1"",$J))
;
K ^TMP($J,"RC TOTAL") ; Clear old totals
W !,$$HDRNM
D DIVISION^VAUTOMA ; Returns VAUTD
I 'VAUTD&($D(VAUTD)'=11) D EN1Q Q
S RCLSTMGR="" ; Initial value, won't be asked if non-null
S (RCXCLUDE("CHAMPVA"),RCXCLUDE("TRICARE"))=0 ; Default to false
S RCDTRNG=$$DTRNG^RCDPEM4()
I 'RCDTRNG D EN1Q Q
S RCDT("BEG")=$P(RCDTRNG,U,2),RCDT("END")=$P(RCDTRNG,U,3)
;
; PRCA*4.5*326 - Ask to show Medical/Pharmacy Tricare CHAMPVA or All
S RCTYPE=$$RTYPE^RCDPEU1("A")
I RCTYPE=-1 D EN1Q Q
;
S RCPAR("SELC")=$$PAYRNG^RCDPEU1() ; PRCA*4.5*326 - Selected or Range of Payers
I RCPAR("SELC")=-1 D EN1Q Q ; PRCA*4.5*326 '^' or timeout
S RCPAY=RCPAR("SELC")
;
I RCPAR("SELC")'="A" D Q:XX=-1 ; PRCA*4.5*326 - Since we don't want all payers
. S RCPAR("TYPE")=RCTYPE ; prompt for payers we do want
. S RCPAR("DICA")="Select Insurance Company NAME: "
. S XX=$$SELPAY^RCDPEU1(.RCPAR)
;
S RCZROBAL=$$ZROBAL() ; Get Zero Balance Filter
I RCZROBAL<0 D EN1Q Q
;
S RCDADJ=$$DADJCDE() ; Get Adjustment/Code Filter ;PRCA*4.5*409 Added line
I RCDADJ<0 D EN1Q Q
;
; Display type, ask for Excel format
S RCDISPTY=$$DISPTY^RCDPEM3()
I RCDISPTY=-1 D EN1Q Q
;
; Display device info about Excel format, set ListMan flag to prevent question
I RCDISPTY S RCLSTMGR="^" D INFO^RCDPEM6
I $D(DUOUT)!$D(DTOUT) D EN1Q Q
S RCJOB=$J ; Needed in RPTOUT
;
; If not output to Excel ask for ListMan display, exit if timeout or '^' - PRCA*4.5*298
I RCLSTMGR="" S RCLSTMGR=$$ASKLM^RCDPEARL G:RCLSTMGR<0 EN1Q
;
; Display in ListMan format and exit on return
I RCLSTMGR D Q
. S RCTMPND=$T(+0)_"^ERA UNMATCHED AGING" K ^TMP($J,RCTMPND) ; clean any residue
. D RPTOUT
. N H,L,HDR S L=0
. S HDR("TITLE")=$$HDRNM
. F H=1:1:7 I $D(RCHDR(H)) S L=H,HDR(H)=RCHDR(H) ; take first 7 lines of report header
. I $O(RCHDR(L)) D ; any remaining header lines at top of report
. . N N S N=0,H=L F S H=$O(RCHDR(H)) Q:'H S N=N+.001,^TMP($J,RCTMPND,N)=RCHDR(H)
. ;
. ; invoke ListMan
. D LMRPT^RCDPEARL(.HDR,$NA(^TMP($J,RCTMPND))) ; generate ListMan display
. D EN1Q
;
; Ask device
N %ZIS S %ZIS="QM"
D ^%ZIS
I POP D EN1Q Q
I $D(IO("Q")) D Q
. N ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE,ZTSK,ZTSTOP
. S ZTRTN="RPTOUT^RCDPEAR1",ZTDESC="AR - EDI LOCKBOX ERA AGING REPORT"
. S ZTSAVE("RC*")="",ZTSAVE("VAUTD")=""
. S ZTSAVE("^TMP(""RCDPEU1"",$J,")="" ; PRCA*4.5*326
. D ^%ZTLOAD
. W !!,$S($G(ZTSK):"Task number "_ZTSK_" has been queued.",1:"Unable to queue this task.")
. K ZTSK,IO("Q")
. D HOME^%ZIS
. D EN1Q
;
U IO
S RCTMPND=""
D RPTOUT
;
EN1Q ; exit and clean up
K ^TMP("RCSELPAY",$J),^TMP("RCPAYER",$J),^TMP("RCDPEU1",$J) ; PRCA*4.5*326
I '$G(RCLSTMGR) D ^%ZISC
Q
;
RPTOUT ; Entry point for listing report
; Input: RCTMPND - Name of the subscript for ^TMP to use to return all lines
; (for bulletin). If undefined or null, output is printed
; Returns: Global if RCTMPND not null: ^TMP($J,RCTMPND,line#)=line text
N ERADT,J,LNECNT,PYMNTFRM,RC0,RCEDT,RCEXCEP,RCFLIEN,RCITM,RCNT,RCSF0,RCZ
N STA,STNAM,STNUM,X,XX,Y,Z,Z0
; ERADT - Date of entry
; LNECNT - # of Lines displayed on the current page
; RCDADJ - Display Adjustment/Code Filter ;PRCA*4.5*409 Added line
; RCNT - Count of items
; RCFLIEN - Entry number in file #344.4
; RCITM - Entry in ^RCY(344.4,0) = ELECTRONIC REMITTANCE ADVICE^344.4I
; RCSF0 - Zero node of sub-file entry
;
S LNECNT=0
S RCTMPND=$G(RCTMPND)
I RCTMPND'="" K ^TMP($J,RCTMPND) ; Clear residual data
K ^TMP($J,"RCERA_AGED"),^TMP($J,"RCERA_ADJ")
S RCFLIEN=0,RCNT=0
F S RCFLIEN=$O(^RCY(344.4,"AMATCH",0,RCFLIEN)) Q:'RCFLIEN D
. K RCITM
. M RCITM=^RCY(344.4,RCFLIEN) ; Grab entire entry
. Q:$P($G(RCITM(6)),U) ; Who removed the ERA - PRCA*4.5*293
. S ERADT=+$P($G(RCITM(0)),U,7) ; (#.07) FILE DATE/TIME [7D]
. Q:'ERADT ; No date, don't include
. ;
. ; Check date range
. Q:(RCDT("BEG")>ERADT\1)!(ERADT\1>RCDT("END"))
. ;
. ; Check Station/Division
. ;I '$$CHKDIV^RCDPEDAR(RCFLIEN,1,.VAUTD) Q
. I 'VAUTD D ERASTA^RCDPEM4(RCFLIEN,.STA,.STNUM,.STNAM) I '$D(VAUTD(STA)) Q
. ;
. I RCPAY'="A" D Q:'XX
. . S XX=$$ISSEL^RCDPEU1(344.4,RCFLIEN) ; PRCA*4.5*326 Check if payer was selected
. E I RCTYPE'="A" D Q:'XX ; If all of a give type of payer selected
. . S XX=$$ISTYPE^RCDPEU1(344.4,RCFLIEN,RCTYPE) ; Check that payer matches type
. ;
. ; Check for Zero Bal
. I 'RCZROBAL,'$P($G(RCITM(0)),U,5) Q ; (#.05) TOTAL AMOUNT PAID [5N]
. S ^TMP($J,"RCERA_AGED",$$FMDIFF^XLFDT(ERADT,DT),RCFLIEN)=0,RCNT=RCNT+1
;
S ^TMP($J,"RC TOTAL","COUNT")=RCNT ; Save counter
;
; Build header, initialize stop flag
D:'RCLSTMGR HDRBLD
S RCSTOP=0
D:RCLSTMGR HDRLM
;
; Excel format, print and exit
I RCDISPTY D EXCEL,^%ZISC,EXIT Q
;
D ; Calculate total amount for ERA
. N T S T=0 ; total
. S RCZ=""
. F D Q:RCZ=""
. . S RCZ=$O(^TMP($J,"RCERA_AGED",RCZ))
. . Q:RCZ=""
. . S RCFLIEN=0
. . F S RCFLIEN=$O(^TMP($J,"RCERA_AGED",RCZ,RCFLIEN)) Q:'RCFLIEN D
. . . S RC0=$G(^RCY(344.4,RCFLIEN,0)),T=T+$P(RC0,U,5)
. ;
. S ^TMP($J,"RC TOTAL","AMOUNT")=T
;
S RCLNCNT=0 ; Line counter
D:'RCLSTMGR HDRLST^RCDPEARL(.RCSTOP,.RCHDR) ; First header in report
;
; List totals
S Y=" Total NUMBER Aged Electronic ERA messages found: "_$FN(^TMP($J,"RC TOTAL","COUNT"),",")
D SL^RCDPEARL(Y,.RCLNCNT,RCTMPND) S LNECNT=LNECNT+1
S Y=" Total AMOUNT Aged Electronic ERA messages found: $"_$FN(^TMP($J,"RC TOTAL","AMOUNT"),",",2)
D SL^RCDPEARL(Y,.RCLNCNT,RCTMPND) S LNECNT=LNECNT+1
;
; If filters selected show total excluded
F J="CHAMPVA","TRICARE" I $G(RCXCLUDE(J)) D
. S Y=" "_J_" exclusion count: "_(+$G(^TMP($J,"RC TOTAL",J)))
. D SL^RCDPEARL(Y,.RCLNCNT,RCTMPND) S LNECNT=LNECNT+1
D SL^RCDPEARL(" "_$TR($J("",78)," ","="),.RCLNCNT,RCTMPND) S LNECNT=LNECNT+1 ; Row of equal signs
;
S RCZ="" F S RCZ=$O(^TMP($J,"RCERA_AGED",RCZ)) Q:RCZ="" S RCFLIEN=0 F S RCFLIEN=$O(^TMP($J,"RCERA_AGED",RCZ,RCFLIEN)) Q:'RCFLIEN D G:RCSTOP EXIT
.I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPGNUM) W:RCTMPND="" !!,"***TASK STOPPED BY USER***" Q
.I RCPGNUM D SL^RCDPEARL(" ",.RCLNCNT,.RCTMPND) S LNECNT=LNECNT+1 ; On detail list, skip line
.I 'RCLSTMGR,'RCPGNUM!(($Y+5)>IOSL) D HDRLST^RCDPEARL(.RCSTOP,.RCHDR) Q:RCSTOP
.S RC0=$G(^RCY(344.4,RCFLIEN,0))
.S RCEXCEP=$$XCEPT^RCDPEWLP(RCFLIEN) ; PRCA*4.5*298 assignment of ERA exception flag (will either be "" or "x")
.S Z=$$SETSTR^VALM1($J(RCEXCEP_-RCZ,4),"",1,5) ; PRCA*4.5*298 display ERA exception flag
.S Z=$$SETSTR^VALM1(" "_$P(RC0,U,2),Z,5,50)
.D SL^RCDPEARL(Z,.RCLNCNT,RCTMPND) S LNECNT=LNECNT+1
.S Z=$$SETSTR^VALM1($$PAYTIN^RCDPRU2($P(RC0,U,6)_"/"_$P(RC0,U,3),78),"",3,78) ; PRCA*4.5*321
.D SL^RCDPEARL(Z,.RCLNCNT,RCTMPND) S LNECNT=LNECNT+1
.S Z=$$SETSTR^VALM1($J("",16)_$S($P(RC0,U,7):$$FMTE^XLFDT($P(RC0,U,7)\1,2),1:""),"",1,25)
.S Z=$$SETSTR^VALM1(" "_$J($P(RC0,U,5),15,2),Z,26,17)
.;
.;PRCA*4.5*409 Added if statement
.I RCDADJ D
..S Z=$$SETSTR^VALM1(" "_+$P(RC0,U,11),Z,43,11)
.;
.;PRCA*4.5*409 Replaced 43 with $S(RCDADJ:54,1:43)
.S Z=$$SETSTR^VALM1(" "_$P(RC0,U),Z_$S('$$HACERA^RCDPEU(RCFLIEN):"",1:" (HAC ERA)"),$S(RCDADJ:54,1:43),16) ; PRCA*4.5*321
.;PRCA*4.5*371 Moved ERA Date column over from 70 to 59 below
.;
.;PRCA*4.5*409 Replaced 59 with $S(RCDADJ:70,1:59)
.S Z=$$SETSTR^VALM1(" "_$$FMTE^XLFDT($P(RC0,U,4),2),Z,$S(RCDADJ:70,1:59),10) ; PRCA*4.5*321
.D SL^RCDPEARL(Z,.RCLNCNT,RCTMPND) S LNECNT=LNECNT+1
.Q:'RCDADJ ;PRCA*4.5*409 Added line
.;
.;PRCA*4.5*409 Added call to new routine due to routine size limitations
.D RPTOUT2^RCDPEAR4
;
; PRCA*4.5*298, put end-of-report into SL^RCDPEARL
I 'RCSTOP D SL^RCDPEARL(" ",.RCLNCNT,RCTMPND),SL^RCDPEARL($$ENDORPRT^RCDPEARL,.RCLNCNT,RCTMPND)
D EXIT
Q
;
EXIT ; Exit the report
; PRCA*4.5*298, added ListMan check
I '$D(ZTQUEUED),'RCLSTMGR D
. I 'RCSTOP,RCPGNUM,RCTMPND="" D ASK^RCDPEARL(.RCSTOP)
. D ^%ZISC
;
S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP($J,"RCERA_AGED"),^TMP("RCSELPAY",$J),^TMP($J,"RC TOTAL"),^TMP("RCDPEU1",$J) ; PRCA*4.5*326
Q
;
HDRBLD ; Create the report header
; Input: RCADJ - 1 - Display Adjustment/Code information, 0 otherwise ;PRCA*4.5*409 Added RCADJ
; RCDISPTY - 1 - Output to excel, 0 otherwise
; RCDTRNG - Date range selected
; RCXCLUDE - TRICARE /CHAMPVA flags
; VAUTD - Divisions to include in report (if listed in VAUTD array)
; Output: RCHDR(0) - Header text line count
; RCHDR(1) - Excel column data (only set If DISPTY=1)
; RCHDR("XECUTE") - M code for page number
; RCHDR("RUNDATE")- Date/time report generated, external format
; RCPGNUM - Page counter
; RCSTOP - Flag to exit
;
N CHATRI,DIV,HCNT,XX,Y
K RCHDR
S RCHDR("RUNDATE")=$$NOW^RCDPEARL,RCPGNUM=0,RCSTOP=0
I RCDISPTY D Q ; Excel format, xecute code is QUIT, null page number
. S RCHDR(0)=1,RCHDR("XECUTE")="Q",RCPGNUM=""
. S XX="Aged Days^Trace #^Payment From/ID^ERA Date^File Date^Amount Paid"
. ;
. ;PRCA*4.5*409 Replaced S XX=XX_"^ERA #" with If/Else below
. I RCDADJ D
. . S XX=XX_"^EEOB Cnt^ERA #^EEOB Detail"
. E D
. . S XX=XX_"^ERA #"
. S RCHDR(1)=XX
;
S XX="N Y S RCPGNUM=RCPGNUM+1,Y=$$HDRNM^"
S XX=XX_$T(+0)_",RCHDR(1)=$J("" "",80-$L(Y)\2)_Y"_"_"" Page: ""_RCPGNUM,LNECNT=RCHDR(0)"
S RCHDR("XECUTE")=XX
S HCNT=1
S Y="RUN DATE: "_RCHDR("RUNDATE"),HCNT=HCNT+1
S RCHDR(HCNT)=$J("",80-$L(Y)\2)_Y
;
; Divisions
S Y="DIVISIONS: "
I $D(VAUTD)=1 S Y=Y_"ALL",Y=$J("",80-$L(Y)\2)_Y,HCNT=HCNT+1,RCHDR(HCNT)=Y
I $D(VAUTD)>1 D
. N S,X S S=0
. F S S=$O(VAUTD(S)) Q:'S D
. . S X=VAUTD(S)_$S($O(VAUTD(S)):", ",1:"")
. . I $L(X)+$L(Y)>80 D
. . . S HCNT=HCNT+1,RCHDR(HCNT)=$J("",80-$L(Y)\2)_Y,Y=$J(" ",12)
. . S Y=Y_X
. ;
. S:$TR(Y," ")]"" HCNT=HCNT+1,RCHDR(HCNT)=Y ; any residual data
;
; Payers - PRCA*4.5*326
S Y="PAYERS: "
S Y=Y_$S(RCPAY="S":"SELECTED",RCPAY="R":"RANGE",1:"ALL")
S Y=Y_$J("",38-$L(Y))_"MEDICAL/PHARMACY/TRICARE/CHAMPVA: " ;PRCA*4.5*432 Add CHAMPVA, 45->38
S Y=Y_$S(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARMACY",RCTYPE="T":"TRICARE",RCTYPE="C":"CHAMPVA",1:"ALL") ;PRCA*4.5*432 Add CHAMPVA
S HCNT=HCNT+1,RCHDR(HCNT)=Y
;
S Y("1ST")=$P(RCDTRNG,U,2),Y("LST")=$P(RCDTRNG,U,3)
F Y="1ST","LST" S Y(Y)=$$FMTE^XLFDT(Y(Y),"2Z")
S Y="DATE RANGE: "_Y("1ST")_" - "_Y("LST")_" (ERA FILE DATE)"
S HCNT=HCNT+1,RCHDR(HCNT)=$J("",80-$L(Y)\2)_Y
;
S HCNT=HCNT+1,RCHDR(HCNT)=""
S Y="AGED"
S HCNT=HCNT+1,RCHDR(HCNT)=Y
S Y="DAYS TRACE #"
S HCNT=HCNT+1,RCHDR(HCNT)=Y
S Y=" PAYMENT FROM/ID" ; PRCA*4.5*321 - Allow extra room for 60 character Payer Name
S HCNT=HCNT+1,RCHDR(HCNT)=Y
;
;PRCA*4.5*371 Removed EEOB CNT below
;PRCA*4.5*409 Replaced S Y=" FILE DATE AMOUNT PAID ERA # ERA DATE"
; with I/E statment below
I RCDADJ D
. S Y=" FILE DATE AMOUNT PAID EEOB CNT ERA # ERA DATE"
E D
. S Y=" FILE DATE AMOUNT PAID ERA # ERA DATE"
S HCNT=HCNT+1,RCHDR(HCNT)=Y
S Y="",$P(Y,"=",80)="",HCNT=HCNT+1,RCHDR(HCNT)=Y
S RCHDR(0)=HCNT ; Total lines in header
Q
;
HDRLM ; Create the list manager version of the report header
; Input: RCDADJ - 1 - Display Adjustment/Code info 0 otherwise ;PRCA*4.5*409 Added RCDADJ
; RCDTRNG - Date range filter value to be printed as part of the
; header
; RCPAY - 1 - All Payers
; 2 - Selected Payers
; RCPAY() - Array of selected Payers if RCPAY=2
; RCLSTMGR -
; VAUTD - 1 - All divisions
; 2 - Selected divisions
; VAUTD() - Array of selected divisions (if VAUTD=2)
; Output: RCHDR(0) - Header text line count
N DATE,DIV,HCNT,MSG,Y,Z0
K RCHDR
S Z0="",RCPGNUM=0,RCSTOP=0
S RCHDR(1)="DATE RANGE: "_$$FMTE^XLFDT($P(RCDTRNG,U,2),"2Z")
S RCHDR(1)=RCHDR(1)_" - "_$$FMTE^XLFDT($P(RCDTRNG,U,3),"2Z")_" (ERA FILE DATE)"
S HCNT=1
;
S Y="DIVISIONS: "
I $D(VAUTD)=1 S Y=Y_"ALL",HCNT=HCNT+1,RCHDR(HCNT)=Y
I $D(VAUTD)>1 D
. N S,X
. S S=0
. F S S=$O(VAUTD(S)) Q:'S D
. . S X=VAUTD(S)_$S($O(VAUTD(S)):", ",1:"")
. . I $L(X)+$L(Y)>80 S HCNT=HCNT+1,RCHDR(HCNT)=Y,Y=$J(" ",12)
. . S Y=Y_X
. ;
. S:$TR(Y," ")]"" HCNT=HCNT+1,RCHDR(HCNT)=Y ; any residual data
;
; Payers - PRCA*4.5*326
S Y="PAYERS: "
S Y=Y_$S(RCPAY="S":"SELECTED",RCPAY="R":"RANGE",1:"ALL")
S Y=Y_$J("",38-$L(Y))_"MEDICAL/PHARMACY/TRICARE/CHAMPVA: " ;PRCA*4.5*432 Add CHAMPVA, 45->38
S Y=Y_$S(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARMACY",RCTYPE="T":"TRICARE",RCTYPE="C":"CHAMPVA",1:"ALL") ;PRCA*4.5*432 Add CHAMPVA
S HCNT=HCNT+1,RCHDR(HCNT)=Y
;
S Y="AGED"
S HCNT=HCNT+1,RCHDR(HCNT)=Y
S Y="DAYS TRACE #"
S HCNT=HCNT+1,RCHDR(HCNT)=Y
S Y=" PAYMENT FROM/ID" ; PRCA*4.5*321 - Allow extra room for 60 character Payer Name
S HCNT=HCNT+1,RCHDR(HCNT)=Y
; PRCA*4.5*371 Removed EEOB CNT below
;PRCA*4.5*409 Replaced S Y=" FILE DATE AMOUNT PAID ERA # ERA DATE"
; with I/E statment below
I RCDADJ D
. S Y=" FILE DATE AMOUNT PAID EEOB CNT ERA # ERA DATE"
E D
. S Y=" FILE DATE AMOUNT PAID ERA # ERA DATE"
S HCNT=HCNT+1,RCHDR(HCNT)=Y
S RCHDR(0)=HCNT ; Total lines in header
Q
;
HDRNM() ; Extrinsic variable, name for header PRCA*4.5*298
Q "ERA UNMATCHED AGING REPORT"
;
EXCEL ; Print report to screen, one record per line for export to MS Excel.
N D,RCSF0,RC1ST,RCEXCEP,RCFLIEN,RCLN,RCSFIEN,RCZ,Z
; RCDADJ - Adjustment/Code filter ;PRCA*4.5*409 Added line
; RCSFIEN - sub-file ien
D HDRLST^RCDPEARL(.RCSTOP,.RCHDR)
S RCZ=""
F S RCZ=$O(^TMP($J,"RCERA_AGED",RCZ)) Q:RCZ="" D
. S RCFLIEN=0
. F S RCFLIEN=$O(^TMP($J,"RCERA_AGED",RCZ,RCFLIEN)) Q:'RCFLIEN D G:RCSTOP PRTQ2
. . I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPGNUM) W:RCTMPND="" !!,"***TASK STOPPED BY USER***" Q
. . S RC0=$G(^RCY(344.4,RCFLIEN,0))
. . S RCEXCEP=$$XCEPT^RCDPEWLP(RCFLIEN) ; PRCA*4.5*298 assignment of ERA exception flag (will either be "" or "x")
. . S Z=$J(RCEXCEP_-RCZ,4)_U_$P(RC0,U,2)_U_$P(RC0,U,6)_"/"_$P(RC0,U,3)
. . ;
. . ;PRCA*4.5*371 Changed external date/times below to be just date (,2 to ,"2D")
. . S Z=Z_U_$$FMTE^XLFDT($P(RC0,U,4),"2D")_U_$$FMTE^XLFDT($P(RC0,U,7),"2D")_U
. . ;
. . ;PRCA*4.5*409 Replaced S Z=Z_$P(RC0,U,5)_U_$P(RC0,U,1) with I/E below
. . I RCDADJ D
. . . S Z=Z_$P(RC0,U,5)_U_$P(RC0,U,11)_U_$P(RC0,U,1)
. . E D
. . . S Z=Z_$P(RC0,U,5)_U_$P(RC0,U,1)
. . W !,Z
. . S RCLN=Z,RC1ST=0
. . Q:'RCDADJ ;PRCA*4.5*409 Added line
. . ;
. . ;PRCA*4.5*409 Begin - Lines restored ePayments Build 17 version of routine
. . K Z
. . I "23"[$$ADJ^RCDPEU(RCFLIEN) D LSTXCEL W "^** CLAIM LEVEL ADJUSTMENTS EXIST FOR THIS ERA ***"
. . I $O(^RCY(344.4,RCFLIEN,2,0)) D ; ERA level adjustments exist
. . . N Q
. . . D DISPADJ^RCDPESR8(RCFLIEN,"^TMP("_$J_",""RCERA_ADJ"")")
. . . I $O(^TMP($J,"RCERA_ADJ",0)) D LSTXCEL W "^** GENERAL ADJUSTMENT DATA EXISTS FOR ERA **"
. . . S Q=0 F S Q=$O(^TMP($J,"RCERA_ADJ",Q)) Q:'Q D LSTXCEL W "^"_$G(^TMP($J,"RCERA_ADJ",Q))
. . ;
. . S RCSFIEN=0 F S RCSFIEN=$O(^RCY(344.4,RCFLIEN,1,RCSFIEN)) Q:'RCSFIEN S RCSF0=$G(^(RCSFIEN,0)) D Q:RCSTOP
. . . N D
. . . K RCOUT
. . . S D=" EEOB Seq #: "_$P(RCSF0,U)_$S($D(^RCY(344.4,RCFLIEN,1,"ATB",1,RCSFIEN)):" (REVERSAL)",1:"")_" EEOB "
. . . S D=D_$S('$P(RCSF0,U,2):"not on file",1:"on file for "_$P($G(^DGCR(399,+$G(^IBM(361.1,+$P(RCSF0,U,2),0)),0)),U))_" "_$J(+$P(RCSF0,U,3),"",2)
. . . D LSTXCEL W "^",D
. . . Q:$P(RCSF0,U,2)
. . . D DISP^RCDPESR0("^RCY(344.4,"_RCFLIEN_",1,"_RCSFIEN_",1)","RCDATA",1,"RCOUT",68,1)
. . . I '$O(RCOUT(0)) D LSTXCEL W "^NO DETAIL FOUND" Q
. . . S Z=0 F S Z=$O(RCOUT(Z)) Q:'Z D Q:RCSTOP
. . . . D LSTXCEL W "^*"_RCOUT(Z)
;
;PRCA*4.5*409 End
;
W !!,$$ENDORPRT^RCDPEARL
Q
;
LSTXCEL ; Display repeat info line before each EEOB detail section.
; First detail line does not need it
I RC1ST W !,RCLN Q
S RC1ST=1 Q
;
PRTQ2 I '$D(ZTQUEUED),'RCSTOP,RCPGNUM,RCTMPND="" D ASK^RCDPEARL(.RCSTOP)
I $D(ZTQUEUED) S ZTREQ="@"
I '$D(ZTQUEUED) D ^%ZISC
K ^TMP($J,"RCEFT_AGED")
Q
;
ZROBAL() ; Get Zero Payment Filter
; Returns: 1 for yes, zero for no, -1 on '^' or timeout
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YA",DIR("A")="Include Zero payment amounts? (Y/N): ",DIR("B")="YES"
D ^DIR
I $D(DUOUT)!$D(DIRUT)!$D(DTOUT) S Y=-1
Q Y
;
DADJCDE() ; Get Adjustment/Code Filter ;PRCA*4.5*409 Added method
; Returns: 1 for yes, zero for no, -1 on '^' or timeout
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YA",DIR("A")="Display Adjustment/Code Information? (Y/N): ",DIR("B")="NO"
D ^DIR
I $D(DUOUT)!$D(DIRUT)!$D(DTOUT) S Y=-1
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEAR1 19245 printed Sep 23, 2025@19:20:25 Page 2
RCDPEAR1 ;ALB/TMK/PJH - ERA Unmatched Aging Report (file #344.4) ;Dec 20, 2014@18:41:35
+1 ;;4.5;Accounts Receivable;**173,269,276,284,293,298,321,326,371,409,432**;Mar 20, 1995;Build 16
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; PRCA*4.5*298 routine completely refactored
EN1 ; entry point - ERA Unmatched Aging Report [RCDPE ERA AGING REPORT]
+1 ; data from ELECTRONIC REMITTANCE ADVICE file (#344.4)
+2 ;PRCA*4.5*409 Added POP,RCADJ
NEW POP,RCDADJ,RCDISPTY,RCDT,RCDTRNG,RCHDR,RCJOB,RCLNCNT,RCLSTMGR,RCOUT
+3 NEW RCPAR,RCPAY,RCPGNUM,RCPYRLST,RCSTOP,RCTMPND,RCTYPE,RCXCLUDE,RCZROBAL,VAUTD,XX,Y
+4 ;
+5 ; RCDADJ - Display Adjustment/Code info flag ;PRCA*4.5*409 Added line
+6 ; RCDISPTY - Display type (Excel)
+7 ; RCDTRNG - Selected date range
+8 ; RCDT("BEG") - Start date, RCDT("END") - end date
+9 ; RCHDR - Header array
+10 ; RCLSTMGR - list manager flag
+11 ; RCDTRNG - "1^start date^end date"
+12 ; RCXCLUDE("CHAMPVA") - boolean, exclude CHAMPVA
+13 ; RCXCLUDE("TRICARE") - boolean, exclude TriCare
+14 ; RCZROBAL - Zero balance flag
+15 ; VAUTD - Division information
+16 ; RCTYPE - MEDICAL/PHARMACY/TRICARE/CHAMPVA/ALL = M/P/T/C/A
+17 ; RCPAY - S=SELECTED, R=RANGE, A=ALL
+18 ; (Selected or range - payers stored in ^TMP(""RCDPEU1"",$J))
+19 ;
+20 ; Clear old totals
KILL ^TMP($JOB,"RC TOTAL")
+21 WRITE !,$$HDRNM
+22 ; Returns VAUTD
DO DIVISION^VAUTOMA
+23 IF 'VAUTD&($DATA(VAUTD)'=11)
DO EN1Q
QUIT
+24 ; Initial value, won't be asked if non-null
SET RCLSTMGR=""
+25 ; Default to false
SET (RCXCLUDE("CHAMPVA"),RCXCLUDE("TRICARE"))=0
+26 SET RCDTRNG=$$DTRNG^RCDPEM4()
+27 IF 'RCDTRNG
DO EN1Q
QUIT
+28 SET RCDT("BEG")=$PIECE(RCDTRNG,U,2)
SET RCDT("END")=$PIECE(RCDTRNG,U,3)
+29 ;
+30 ; PRCA*4.5*326 - Ask to show Medical/Pharmacy Tricare CHAMPVA or All
+31 SET RCTYPE=$$RTYPE^RCDPEU1("A")
+32 IF RCTYPE=-1
DO EN1Q
QUIT
+33 ;
+34 ; PRCA*4.5*326 - Selected or Range of Payers
SET RCPAR("SELC")=$$PAYRNG^RCDPEU1()
+35 ; PRCA*4.5*326 '^' or timeout
IF RCPAR("SELC")=-1
DO EN1Q
QUIT
+36 SET RCPAY=RCPAR("SELC")
+37 ;
+38 ; PRCA*4.5*326 - Since we don't want all payers
IF RCPAR("SELC")'="A"
Begin DoDot:1
+39 ; prompt for payers we do want
SET RCPAR("TYPE")=RCTYPE
+40 SET RCPAR("DICA")="Select Insurance Company NAME: "
+41 SET XX=$$SELPAY^RCDPEU1(.RCPAR)
End DoDot:1
if XX=-1
QUIT
+42 ;
+43 ; Get Zero Balance Filter
SET RCZROBAL=$$ZROBAL()
+44 IF RCZROBAL<0
DO EN1Q
QUIT
+45 ;
+46 ; Get Adjustment/Code Filter ;PRCA*4.5*409 Added line
SET RCDADJ=$$DADJCDE()
+47 IF RCDADJ<0
DO EN1Q
QUIT
+48 ;
+49 ; Display type, ask for Excel format
+50 SET RCDISPTY=$$DISPTY^RCDPEM3()
+51 IF RCDISPTY=-1
DO EN1Q
QUIT
+52 ;
+53 ; Display device info about Excel format, set ListMan flag to prevent question
+54 IF RCDISPTY
SET RCLSTMGR="^"
DO INFO^RCDPEM6
+55 IF $DATA(DUOUT)!$DATA(DTOUT)
DO EN1Q
QUIT
+56 ; Needed in RPTOUT
SET RCJOB=$JOB
+57 ;
+58 ; If not output to Excel ask for ListMan display, exit if timeout or '^' - PRCA*4.5*298
+59 IF RCLSTMGR=""
SET RCLSTMGR=$$ASKLM^RCDPEARL
if RCLSTMGR<0
GOTO EN1Q
+60 ;
+61 ; Display in ListMan format and exit on return
+62 IF RCLSTMGR
Begin DoDot:1
+63 ; clean any residue
SET RCTMPND=$TEXT(+0)_"^ERA UNMATCHED AGING"
KILL ^TMP($JOB,RCTMPND)
+64 DO RPTOUT
+65 NEW H,L,HDR
SET L=0
+66 SET HDR("TITLE")=$$HDRNM
+67 ; take first 7 lines of report header
FOR H=1:1:7
IF $DATA(RCHDR(H))
SET L=H
SET HDR(H)=RCHDR(H)
+68 ; any remaining header lines at top of report
IF $ORDER(RCHDR(L))
Begin DoDot:2
+69 NEW N
SET N=0
SET H=L
FOR
SET H=$ORDER(RCHDR(H))
if 'H
QUIT
SET N=N+.001
SET ^TMP($JOB,RCTMPND,N)=RCHDR(H)
End DoDot:2
+70 ;
+71 ; invoke ListMan
+72 ; generate ListMan display
DO LMRPT^RCDPEARL(.HDR,$NAME(^TMP($JOB,RCTMPND)))
+73 DO EN1Q
End DoDot:1
QUIT
+74 ;
+75 ; Ask device
+76 NEW %ZIS
SET %ZIS="QM"
+77 DO ^%ZIS
+78 IF POP
DO EN1Q
QUIT
+79 IF $DATA(IO("Q"))
Begin DoDot:1
+80 NEW ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE,ZTSK,ZTSTOP
+81 SET ZTRTN="RPTOUT^RCDPEAR1"
SET ZTDESC="AR - EDI LOCKBOX ERA AGING REPORT"
+82 SET ZTSAVE("RC*")=""
SET ZTSAVE("VAUTD")=""
+83 ; PRCA*4.5*326
SET ZTSAVE("^TMP(""RCDPEU1"",$J,")=""
+84 DO ^%ZTLOAD
+85 WRITE !!,$SELECT($GET(ZTSK):"Task number "_ZTSK_" has been queued.",1:"Unable to queue this task.")
+86 KILL ZTSK,IO("Q")
+87 DO HOME^%ZIS
+88 DO EN1Q
End DoDot:1
QUIT
+89 ;
+90 USE IO
+91 SET RCTMPND=""
+92 DO RPTOUT
+93 ;
EN1Q ; exit and clean up
+1 ; PRCA*4.5*326
KILL ^TMP("RCSELPAY",$JOB),^TMP("RCPAYER",$JOB),^TMP("RCDPEU1",$JOB)
+2 IF '$GET(RCLSTMGR)
DO ^%ZISC
+3 QUIT
+4 ;
RPTOUT ; Entry point for listing report
+1 ; Input: RCTMPND - Name of the subscript for ^TMP to use to return all lines
+2 ; (for bulletin). If undefined or null, output is printed
+3 ; Returns: Global if RCTMPND not null: ^TMP($J,RCTMPND,line#)=line text
+4 NEW ERADT,J,LNECNT,PYMNTFRM,RC0,RCEDT,RCEXCEP,RCFLIEN,RCITM,RCNT,RCSF0,RCZ
+5 NEW STA,STNAM,STNUM,X,XX,Y,Z,Z0
+6 ; ERADT - Date of entry
+7 ; LNECNT - # of Lines displayed on the current page
+8 ; RCDADJ - Display Adjustment/Code Filter ;PRCA*4.5*409 Added line
+9 ; RCNT - Count of items
+10 ; RCFLIEN - Entry number in file #344.4
+11 ; RCITM - Entry in ^RCY(344.4,0) = ELECTRONIC REMITTANCE ADVICE^344.4I
+12 ; RCSF0 - Zero node of sub-file entry
+13 ;
+14 SET LNECNT=0
+15 SET RCTMPND=$GET(RCTMPND)
+16 ; Clear residual data
IF RCTMPND'=""
KILL ^TMP($JOB,RCTMPND)
+17 KILL ^TMP($JOB,"RCERA_AGED"),^TMP($JOB,"RCERA_ADJ")
+18 SET RCFLIEN=0
SET RCNT=0
+19 FOR
SET RCFLIEN=$ORDER(^RCY(344.4,"AMATCH",0,RCFLIEN))
if 'RCFLIEN
QUIT
Begin DoDot:1
+20 KILL RCITM
+21 ; Grab entire entry
MERGE RCITM=^RCY(344.4,RCFLIEN)
+22 ; Who removed the ERA - PRCA*4.5*293
if $PIECE($GET(RCITM(6)),U)
QUIT
+23 ; (#.07) FILE DATE/TIME [7D]
SET ERADT=+$PIECE($GET(RCITM(0)),U,7)
+24 ; No date, don't include
if 'ERADT
QUIT
+25 ;
+26 ; Check date range
+27 if (RCDT("BEG")>ERADT\1)!(ERADT\1>RCDT("END"))
QUIT
+28 ;
+29 ; Check Station/Division
+30 ;I '$$CHKDIV^RCDPEDAR(RCFLIEN,1,.VAUTD) Q
+31 IF 'VAUTD
DO ERASTA^RCDPEM4(RCFLIEN,.STA,.STNUM,.STNAM)
IF '$DATA(VAUTD(STA))
QUIT
+32 ;
+33 IF RCPAY'="A"
Begin DoDot:2
+34 ; PRCA*4.5*326 Check if payer was selected
SET XX=$$ISSEL^RCDPEU1(344.4,RCFLIEN)
End DoDot:2
if 'XX
QUIT
+35 ; If all of a give type of payer selected
IF '$TEST
IF RCTYPE'="A"
Begin DoDot:2
+36 ; Check that payer matches type
SET XX=$$ISTYPE^RCDPEU1(344.4,RCFLIEN,RCTYPE)
End DoDot:2
if 'XX
QUIT
+37 ;
+38 ; Check for Zero Bal
+39 ; (#.05) TOTAL AMOUNT PAID [5N]
IF 'RCZROBAL
IF '$PIECE($GET(RCITM(0)),U,5)
QUIT
+40 SET ^TMP($JOB,"RCERA_AGED",$$FMDIFF^XLFDT(ERADT,DT),RCFLIEN)=0
SET RCNT=RCNT+1
End DoDot:1
+41 ;
+42 ; Save counter
SET ^TMP($JOB,"RC TOTAL","COUNT")=RCNT
+43 ;
+44 ; Build header, initialize stop flag
+45 if 'RCLSTMGR
DO HDRBLD
+46 SET RCSTOP=0
+47 if RCLSTMGR
DO HDRLM
+48 ;
+49 ; Excel format, print and exit
+50 IF RCDISPTY
DO EXCEL
DO ^%ZISC
DO EXIT
QUIT
+51 ;
+52 ; Calculate total amount for ERA
Begin DoDot:1
+53 ; total
NEW T
SET T=0
+54 SET RCZ=""
+55 FOR
Begin DoDot:2
+56 SET RCZ=$ORDER(^TMP($JOB,"RCERA_AGED",RCZ))
+57 if RCZ=""
QUIT
+58 SET RCFLIEN=0
+59 FOR
SET RCFLIEN=$ORDER(^TMP($JOB,"RCERA_AGED",RCZ,RCFLIEN))
if 'RCFLIEN
QUIT
Begin DoDot:3
+60 SET RC0=$GET(^RCY(344.4,RCFLIEN,0))
SET T=T+$PIECE(RC0,U,5)
End DoDot:3
End DoDot:2
if RCZ=""
QUIT
+61 ;
+62 SET ^TMP($JOB,"RC TOTAL","AMOUNT")=T
End DoDot:1
+63 ;
+64 ; Line counter
SET RCLNCNT=0
+65 ; First header in report
if 'RCLSTMGR
DO HDRLST^RCDPEARL(.RCSTOP,.RCHDR)
+66 ;
+67 ; List totals
+68 SET Y=" Total NUMBER Aged Electronic ERA messages found: "_$FNUMBER(^TMP($JOB,"RC TOTAL","COUNT"),",")
+69 DO SL^RCDPEARL(Y,.RCLNCNT,RCTMPND)
SET LNECNT=LNECNT+1
+70 SET Y=" Total AMOUNT Aged Electronic ERA messages found: $"_$FNUMBER(^TMP($JOB,"RC TOTAL","AMOUNT"),",",2)
+71 DO SL^RCDPEARL(Y,.RCLNCNT,RCTMPND)
SET LNECNT=LNECNT+1
+72 ;
+73 ; If filters selected show total excluded
+74 FOR J="CHAMPVA","TRICARE"
IF $GET(RCXCLUDE(J))
Begin DoDot:1
+75 SET Y=" "_J_" exclusion count: "_(+$GET(^TMP($JOB,"RC TOTAL",J)))
+76 DO SL^RCDPEARL(Y,.RCLNCNT,RCTMPND)
SET LNECNT=LNECNT+1
End DoDot:1
+77 ; Row of equal signs
DO SL^RCDPEARL(" "_$TRANSLATE($JUSTIFY("",78)," ","="),.RCLNCNT,RCTMPND)
SET LNECNT=LNECNT+1
+78 ;
+79 SET RCZ=""
FOR
SET RCZ=$ORDER(^TMP($JOB,"RCERA_AGED",RCZ))
if RCZ=""
QUIT
SET RCFLIEN=0
FOR
SET RCFLIEN=$ORDER(^TMP($JOB,"RCERA_AGED",RCZ,RCFLIEN))
if 'RCFLIEN
QUIT
Begin DoDot:1
+80 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (RCSTOP,ZTSTOP)=1
KILL ZTREQ
IF +$GET(RCPGNUM)
if RCTMPND=""
WRITE !!,"***TASK STOPPED BY USER***"
QUIT
+81 ; On detail list, skip line
IF RCPGNUM
DO SL^RCDPEARL(" ",.RCLNCNT,.RCTMPND)
SET LNECNT=LNECNT+1
+82 IF 'RCLSTMGR
IF 'RCPGNUM!(($Y+5)>IOSL)
DO HDRLST^RCDPEARL(.RCSTOP,.RCHDR)
if RCSTOP
QUIT
+83 SET RC0=$GET(^RCY(344.4,RCFLIEN,0))
+84 ; PRCA*4.5*298 assignment of ERA exception flag (will either be "" or "x")
SET RCEXCEP=$$XCEPT^RCDPEWLP(RCFLIEN)
+85 ; PRCA*4.5*298 display ERA exception flag
SET Z=$$SETSTR^VALM1($JUSTIFY(RCEXCEP_-RCZ,4),"",1,5)
+86 SET Z=$$SETSTR^VALM1(" "_$PIECE(RC0,U,2),Z,5,50)
+87 DO SL^RCDPEARL(Z,.RCLNCNT,RCTMPND)
SET LNECNT=LNECNT+1
+88 ; PRCA*4.5*321
SET Z=$$SETSTR^VALM1($$PAYTIN^RCDPRU2($PIECE(RC0,U,6)_"/"_$PIECE(RC0,U,3),78),"",3,78)
+89 DO SL^RCDPEARL(Z,.RCLNCNT,RCTMPND)
SET LNECNT=LNECNT+1
+90 SET Z=$$SETSTR^VALM1($JUSTIFY("",16)_$SELECT($PIECE(RC0,U,7):$$FMTE^XLFDT($PIECE(RC0,U,7)\1,2),1:""),"",1,25)
+91 SET Z=$$SETSTR^VALM1(" "_$JUSTIFY($PIECE(RC0,U,5),15,2),Z,26,17)
+92 ;
+93 ;PRCA*4.5*409 Added if statement
+94 IF RCDADJ
Begin DoDot:2
+95 SET Z=$$SETSTR^VALM1(" "_+$PIECE(RC0,U,11),Z,43,11)
End DoDot:2
+96 ;
+97 ;PRCA*4.5*409 Replaced 43 with $S(RCDADJ:54,1:43)
+98 ; PRCA*4.5*321
SET Z=$$SETSTR^VALM1(" "_$PIECE(RC0,U),Z_$SELECT('$$HACERA^RCDPEU(RCFLIEN):"",1:" (HAC ERA)"),$SELECT(RCDADJ:54,1:43),16)
+99 ;PRCA*4.5*371 Moved ERA Date column over from 70 to 59 below
+100 ;
+101 ;PRCA*4.5*409 Replaced 59 with $S(RCDADJ:70,1:59)
+102 ; PRCA*4.5*321
SET Z=$$SETSTR^VALM1(" "_$$FMTE^XLFDT($PIECE(RC0,U,4),2),Z,$SELECT(RCDADJ:70,1:59),10)
+103 DO SL^RCDPEARL(Z,.RCLNCNT,RCTMPND)
SET LNECNT=LNECNT+1
+104 ;PRCA*4.5*409 Added line
if 'RCDADJ
QUIT
+105 ;
+106 ;PRCA*4.5*409 Added call to new routine due to routine size limitations
+107 DO RPTOUT2^RCDPEAR4
End DoDot:1
if RCSTOP
GOTO EXIT
+108 ;
+109 ; PRCA*4.5*298, put end-of-report into SL^RCDPEARL
+110 IF 'RCSTOP
DO SL^RCDPEARL(" ",.RCLNCNT,RCTMPND)
DO SL^RCDPEARL($$ENDORPRT^RCDPEARL,.RCLNCNT,RCTMPND)
+111 DO EXIT
+112 QUIT
+113 ;
EXIT ; Exit the report
+1 ; PRCA*4.5*298, added ListMan check
+2 IF '$DATA(ZTQUEUED)
IF 'RCLSTMGR
Begin DoDot:1
+3 IF 'RCSTOP
IF RCPGNUM
IF RCTMPND=""
DO ASK^RCDPEARL(.RCSTOP)
+4 DO ^%ZISC
End DoDot:1
+5 ;
+6 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 ; PRCA*4.5*326
KILL ^TMP($JOB,"RCERA_AGED"),^TMP("RCSELPAY",$JOB),^TMP($JOB,"RC TOTAL"),^TMP("RCDPEU1",$JOB)
+8 QUIT
+9 ;
HDRBLD ; Create the report header
+1 ; Input: RCADJ - 1 - Display Adjustment/Code information, 0 otherwise ;PRCA*4.5*409 Added RCADJ
+2 ; RCDISPTY - 1 - Output to excel, 0 otherwise
+3 ; RCDTRNG - Date range selected
+4 ; RCXCLUDE - TRICARE /CHAMPVA flags
+5 ; VAUTD - Divisions to include in report (if listed in VAUTD array)
+6 ; Output: RCHDR(0) - Header text line count
+7 ; RCHDR(1) - Excel column data (only set If DISPTY=1)
+8 ; RCHDR("XECUTE") - M code for page number
+9 ; RCHDR("RUNDATE")- Date/time report generated, external format
+10 ; RCPGNUM - Page counter
+11 ; RCSTOP - Flag to exit
+12 ;
+13 NEW CHATRI,DIV,HCNT,XX,Y
+14 KILL RCHDR
+15 SET RCHDR("RUNDATE")=$$NOW^RCDPEARL
SET RCPGNUM=0
SET RCSTOP=0
+16 ; Excel format, xecute code is QUIT, null page number
IF RCDISPTY
Begin DoDot:1
+17 SET RCHDR(0)=1
SET RCHDR("XECUTE")="Q"
SET RCPGNUM=""
+18 SET XX="Aged Days^Trace #^Payment From/ID^ERA Date^File Date^Amount Paid"
+19 ;
+20 ;PRCA*4.5*409 Replaced S XX=XX_"^ERA #" with If/Else below
+21 IF RCDADJ
Begin DoDot:2
+22 SET XX=XX_"^EEOB Cnt^ERA #^EEOB Detail"
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 SET XX=XX_"^ERA #"
End DoDot:2
+25 SET RCHDR(1)=XX
End DoDot:1
QUIT
+26 ;
+27 SET XX="N Y S RCPGNUM=RCPGNUM+1,Y=$$HDRNM^"
+28 SET XX=XX_$TEXT(+0)_",RCHDR(1)=$J("" "",80-$L(Y)\2)_Y"_"_"" Page: ""_RCPGNUM,LNECNT=RCHDR(0)"
+29 SET RCHDR("XECUTE")=XX
+30 SET HCNT=1
+31 SET Y="RUN DATE: "_RCHDR("RUNDATE")
SET HCNT=HCNT+1
+32 SET RCHDR(HCNT)=$JUSTIFY("",80-$LENGTH(Y)\2)_Y
+33 ;
+34 ; Divisions
+35 SET Y="DIVISIONS: "
+36 IF $DATA(VAUTD)=1
SET Y=Y_"ALL"
SET Y=$JUSTIFY("",80-$LENGTH(Y)\2)_Y
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+37 IF $DATA(VAUTD)>1
Begin DoDot:1
+38 NEW S,X
SET S=0
+39 FOR
SET S=$ORDER(VAUTD(S))
if 'S
QUIT
Begin DoDot:2
+40 SET X=VAUTD(S)_$SELECT($ORDER(VAUTD(S)):", ",1:"")
+41 IF $LENGTH(X)+$LENGTH(Y)>80
Begin DoDot:3
+42 SET HCNT=HCNT+1
SET RCHDR(HCNT)=$JUSTIFY("",80-$LENGTH(Y)\2)_Y
SET Y=$JUSTIFY(" ",12)
End DoDot:3
+43 SET Y=Y_X
End DoDot:2
+44 ;
+45 ; any residual data
if $TRANSLATE(Y," ")]""
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
End DoDot:1
+46 ;
+47 ; Payers - PRCA*4.5*326
+48 SET Y="PAYERS: "
+49 SET Y=Y_$SELECT(RCPAY="S":"SELECTED",RCPAY="R":"RANGE",1:"ALL")
+50 ;PRCA*4.5*432 Add CHAMPVA, 45->38
SET Y=Y_$JUSTIFY("",38-$LENGTH(Y))_"MEDICAL/PHARMACY/TRICARE/CHAMPVA: "
+51 ;PRCA*4.5*432 Add CHAMPVA
SET Y=Y_$SELECT(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARMACY",RCTYPE="T":"TRICARE",RCTYPE="C":"CHAMPVA",1:"ALL")
+52 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+53 ;
+54 SET Y("1ST")=$PIECE(RCDTRNG,U,2)
SET Y("LST")=$PIECE(RCDTRNG,U,3)
+55 FOR Y="1ST","LST"
SET Y(Y)=$$FMTE^XLFDT(Y(Y),"2Z")
+56 SET Y="DATE RANGE: "_Y("1ST")_" - "_Y("LST")_" (ERA FILE DATE)"
+57 SET HCNT=HCNT+1
SET RCHDR(HCNT)=$JUSTIFY("",80-$LENGTH(Y)\2)_Y
+58 ;
+59 SET HCNT=HCNT+1
SET RCHDR(HCNT)=""
+60 SET Y="AGED"
+61 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+62 SET Y="DAYS TRACE #"
+63 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+64 ; PRCA*4.5*321 - Allow extra room for 60 character Payer Name
SET Y=" PAYMENT FROM/ID"
+65 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+66 ;
+67 ;PRCA*4.5*371 Removed EEOB CNT below
+68 ;PRCA*4.5*409 Replaced S Y=" FILE DATE AMOUNT PAID ERA # ERA DATE"
+69 ; with I/E statment below
+70 IF RCDADJ
Begin DoDot:1
+71 SET Y=" FILE DATE AMOUNT PAID EEOB CNT ERA # ERA DATE"
End DoDot:1
+72 IF '$TEST
Begin DoDot:1
+73 SET Y=" FILE DATE AMOUNT PAID ERA # ERA DATE"
End DoDot:1
+74 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+75 SET Y=""
SET $PIECE(Y,"=",80)=""
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+76 ; Total lines in header
SET RCHDR(0)=HCNT
+77 QUIT
+78 ;
HDRLM ; Create the list manager version of the report header
+1 ; Input: RCDADJ - 1 - Display Adjustment/Code info 0 otherwise ;PRCA*4.5*409 Added RCDADJ
+2 ; RCDTRNG - Date range filter value to be printed as part of the
+3 ; header
+4 ; RCPAY - 1 - All Payers
+5 ; 2 - Selected Payers
+6 ; RCPAY() - Array of selected Payers if RCPAY=2
+7 ; RCLSTMGR -
+8 ; VAUTD - 1 - All divisions
+9 ; 2 - Selected divisions
+10 ; VAUTD() - Array of selected divisions (if VAUTD=2)
+11 ; Output: RCHDR(0) - Header text line count
+12 NEW DATE,DIV,HCNT,MSG,Y,Z0
+13 KILL RCHDR
+14 SET Z0=""
SET RCPGNUM=0
SET RCSTOP=0
+15 SET RCHDR(1)="DATE RANGE: "_$$FMTE^XLFDT($PIECE(RCDTRNG,U,2),"2Z")
+16 SET RCHDR(1)=RCHDR(1)_" - "_$$FMTE^XLFDT($PIECE(RCDTRNG,U,3),"2Z")_" (ERA FILE DATE)"
+17 SET HCNT=1
+18 ;
+19 SET Y="DIVISIONS: "
+20 IF $DATA(VAUTD)=1
SET Y=Y_"ALL"
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+21 IF $DATA(VAUTD)>1
Begin DoDot:1
+22 NEW S,X
+23 SET S=0
+24 FOR
SET S=$ORDER(VAUTD(S))
if 'S
QUIT
Begin DoDot:2
+25 SET X=VAUTD(S)_$SELECT($ORDER(VAUTD(S)):", ",1:"")
+26 IF $LENGTH(X)+$LENGTH(Y)>80
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
SET Y=$JUSTIFY(" ",12)
+27 SET Y=Y_X
End DoDot:2
+28 ;
+29 ; any residual data
if $TRANSLATE(Y," ")]""
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
End DoDot:1
+30 ;
+31 ; Payers - PRCA*4.5*326
+32 SET Y="PAYERS: "
+33 SET Y=Y_$SELECT(RCPAY="S":"SELECTED",RCPAY="R":"RANGE",1:"ALL")
+34 ;PRCA*4.5*432 Add CHAMPVA, 45->38
SET Y=Y_$JUSTIFY("",38-$LENGTH(Y))_"MEDICAL/PHARMACY/TRICARE/CHAMPVA: "
+35 ;PRCA*4.5*432 Add CHAMPVA
SET Y=Y_$SELECT(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARMACY",RCTYPE="T":"TRICARE",RCTYPE="C":"CHAMPVA",1:"ALL")
+36 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+37 ;
+38 SET Y="AGED"
+39 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+40 SET Y="DAYS TRACE #"
+41 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+42 ; PRCA*4.5*321 - Allow extra room for 60 character Payer Name
SET Y=" PAYMENT FROM/ID"
+43 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+44 ; PRCA*4.5*371 Removed EEOB CNT below
+45 ;PRCA*4.5*409 Replaced S Y=" FILE DATE AMOUNT PAID ERA # ERA DATE"
+46 ; with I/E statment below
+47 IF RCDADJ
Begin DoDot:1
+48 SET Y=" FILE DATE AMOUNT PAID EEOB CNT ERA # ERA DATE"
End DoDot:1
+49 IF '$TEST
Begin DoDot:1
+50 SET Y=" FILE DATE AMOUNT PAID ERA # ERA DATE"
End DoDot:1
+51 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+52 ; Total lines in header
SET RCHDR(0)=HCNT
+53 QUIT
+54 ;
HDRNM() ; Extrinsic variable, name for header PRCA*4.5*298
+1 QUIT "ERA UNMATCHED AGING REPORT"
+2 ;
EXCEL ; Print report to screen, one record per line for export to MS Excel.
+1 NEW D,RCSF0,RC1ST,RCEXCEP,RCFLIEN,RCLN,RCSFIEN,RCZ,Z
+2 ; RCDADJ - Adjustment/Code filter ;PRCA*4.5*409 Added line
+3 ; RCSFIEN - sub-file ien
+4 DO HDRLST^RCDPEARL(.RCSTOP,.RCHDR)
+5 SET RCZ=""
+6 FOR
SET RCZ=$ORDER(^TMP($JOB,"RCERA_AGED",RCZ))
if RCZ=""
QUIT
Begin DoDot:1
+7 SET RCFLIEN=0
+8 FOR
SET RCFLIEN=$ORDER(^TMP($JOB,"RCERA_AGED",RCZ,RCFLIEN))
if 'RCFLIEN
QUIT
Begin DoDot:2
+9 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (RCSTOP,ZTSTOP)=1
KILL ZTREQ
IF +$GET(RCPGNUM)
if RCTMPND=""
WRITE !!,"***TASK STOPPED BY USER***"
QUIT
+10 SET RC0=$GET(^RCY(344.4,RCFLIEN,0))
+11 ; PRCA*4.5*298 assignment of ERA exception flag (will either be "" or "x")
SET RCEXCEP=$$XCEPT^RCDPEWLP(RCFLIEN)
+12 SET Z=$JUSTIFY(RCEXCEP_-RCZ,4)_U_$PIECE(RC0,U,2)_U_$PIECE(RC0,U,6)_"/"_$PIECE(RC0,U,3)
+13 ;
+14 ;PRCA*4.5*371 Changed external date/times below to be just date (,2 to ,"2D")
+15 SET Z=Z_U_$$FMTE^XLFDT($PIECE(RC0,U,4),"2D")_U_$$FMTE^XLFDT($PIECE(RC0,U,7),"2D")_U
+16 ;
+17 ;PRCA*4.5*409 Replaced S Z=Z_$P(RC0,U,5)_U_$P(RC0,U,1) with I/E below
+18 IF RCDADJ
Begin DoDot:3
+19 SET Z=Z_$PIECE(RC0,U,5)_U_$PIECE(RC0,U,11)_U_$PIECE(RC0,U,1)
End DoDot:3
+20 IF '$TEST
Begin DoDot:3
+21 SET Z=Z_$PIECE(RC0,U,5)_U_$PIECE(RC0,U,1)
End DoDot:3
+22 WRITE !,Z
+23 SET RCLN=Z
SET RC1ST=0
+24 ;PRCA*4.5*409 Added line
if 'RCDADJ
QUIT
+25 ;
+26 ;PRCA*4.5*409 Begin - Lines restored ePayments Build 17 version of routine
+27 KILL Z
+28 IF "23"[$$ADJ^RCDPEU(RCFLIEN)
DO LSTXCEL
WRITE "^** CLAIM LEVEL ADJUSTMENTS EXIST FOR THIS ERA ***"
+29 ; ERA level adjustments exist
IF $ORDER(^RCY(344.4,RCFLIEN,2,0))
Begin DoDot:3
+30 NEW Q
+31 DO DISPADJ^RCDPESR8(RCFLIEN,"^TMP("_$JOB_",""RCERA_ADJ"")")
+32 IF $ORDER(^TMP($JOB,"RCERA_ADJ",0))
DO LSTXCEL
WRITE "^** GENERAL ADJUSTMENT DATA EXISTS FOR ERA **"
+33 SET Q=0
FOR
SET Q=$ORDER(^TMP($JOB,"RCERA_ADJ",Q))
if 'Q
QUIT
DO LSTXCEL
WRITE "^"_$GET(^TMP($JOB,"RCERA_ADJ",Q))
End DoDot:3
+34 ;
+35 SET RCSFIEN=0
FOR
SET RCSFIEN=$ORDER(^RCY(344.4,RCFLIEN,1,RCSFIEN))
if 'RCSFIEN
QUIT
SET RCSF0=$GET(^(RCSFIEN,0))
Begin DoDot:3
+36 NEW D
+37 KILL RCOUT
+38 SET D=" EEOB Seq #: "_$PIECE(RCSF0,U)_$SELECT($DATA(^RCY(344.4,RCFLIEN,1,"ATB",1,RCSFIEN)):" (REVERSAL)",1:"")_" EEOB "
+39 SET D=D_$SELECT('$PIECE(RCSF0,U,2):"not on file",1:"on file for "_$PIECE($GET(^DGCR(399,+$GET(^IBM(361.1,+$PIECE(RCSF0,U,2),0)),0)),U))_" "_$JUSTIFY(+$PIECE(RCSF0,U,3),"",2)
+40 DO LSTXCEL
WRITE "^",D
+41 if $PIECE(RCSF0,U,2)
QUIT
+42 DO DISP^RCDPESR0("^RCY(344.4,"_RCFLIEN_",1,"_RCSFIEN_",1)","RCDATA",1,"RCOUT",68,1)
+43 IF '$ORDER(RCOUT(0))
DO LSTXCEL
WRITE "^NO DETAIL FOUND"
QUIT
+44 SET Z=0
FOR
SET Z=$ORDER(RCOUT(Z))
if 'Z
QUIT
Begin DoDot:4
+45 DO LSTXCEL
WRITE "^*"_RCOUT(Z)
End DoDot:4
if RCSTOP
QUIT
End DoDot:3
if RCSTOP
QUIT
End DoDot:2
if RCSTOP
GOTO PRTQ2
End DoDot:1
+46 ;
+47 ;PRCA*4.5*409 End
+48 ;
+49 WRITE !!,$$ENDORPRT^RCDPEARL
+50 QUIT
+51 ;
LSTXCEL ; Display repeat info line before each EEOB detail section.
+1 ; First detail line does not need it
+2 IF RC1ST
WRITE !,RCLN
QUIT
+3 SET RC1ST=1
QUIT
+4 ;
PRTQ2 IF '$DATA(ZTQUEUED)
IF 'RCSTOP
IF RCPGNUM
IF RCTMPND=""
DO ASK^RCDPEARL(.RCSTOP)
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$DATA(ZTQUEUED)
DO ^%ZISC
+3 KILL ^TMP($JOB,"RCEFT_AGED")
+4 QUIT
+5 ;
ZROBAL() ; Get Zero Payment Filter
+1 ; Returns: 1 for yes, zero for no, -1 on '^' or timeout
+2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="YA"
SET DIR("A")="Include Zero payment amounts? (Y/N): "
SET DIR("B")="YES"
+4 DO ^DIR
+5 IF $DATA(DUOUT)!$DATA(DIRUT)!$DATA(DTOUT)
SET Y=-1
+6 QUIT Y
+7 ;
DADJCDE() ; Get Adjustment/Code Filter ;PRCA*4.5*409 Added method
+1 ; Returns: 1 for yes, zero for no, -1 on '^' or timeout
+2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="YA"
SET DIR("A")="Display Adjustment/Code Information? (Y/N): "
SET DIR("B")="NO"
+4 DO ^DIR
+5 IF $DATA(DUOUT)!$DATA(DIRUT)!$DATA(DTOUT)
SET Y=-1
+6 QUIT Y
+7 ;
