RCDPRU ;ALB/TJB - CARC REPORT ON PAYER OR CARC CODE ;9/15/14 3:00pm
;;4.5;Accounts Receivable;**303,321,326**;Mar 20, 1995;Build 26
;;Per VA Directive 6402, this routine should not be modified.
Q
; PRCA*4.5*303 - CARC and Payer report utilities
; IA 594 - ACCOUNTS RECEIVABLE CATEGORY file (#430.2)
; IA 1077 - Using DIVISION^VAUTOMA to query for division
; IA 1992 - BILL/CLAIMS file (#399)
; IA 3820 - BILL/CLAIMS file (#399)
; IA 3822 - RATE TYPE file (#399.3)
; IA 4051 - EXPLANATION OF BENEFITS file (#361.1)
; IA 4996 - BILL/CLAIMS file (#399)
;
DISPTY() ; function, ask display/output type
; processes input from user
; returns: Output destination (0=Display, 1=MS Excel, -1=timeout or '^)
N DIR,DUOUT,DIRUT,X,Y
S DIR(0)="YA",DIR("A")="Export the report to Microsoft Excel? (Y/N): ",DIR("B")="NO"
D ^DIR
I $D(DUOUT)!$D(DIRUT) S Y=-1
Q Y
;
INFO ; Useful Info for Excel capture
N SP S SP=$J(" ",10) ; spaces
W !!!,SP_"Before continuing, please set up your terminal to capture the"
W !,SP_"report data as this report may take a while to run."
W !!,SP_"To avoid undesired wrapping of the data saved to the"
W !,SP_"file, please enter '0;256;999' at the 'DEVICE:' prompt."
W !!,SP_"It may be necessary to set the terminal's display width"
W !,SP_"to 256 characters, which can be performed by selecting the"
W !,SP_"Display option located within the 'Setup' menu on the"
W !,SP_"tool bar of the terminal emulation software (e.g. KEA,"
W !,SP_"Reflection, or Smarterm).",!!
Q
;
ASK(RCSTOP) ; User if you want to quit or continue
S RCSTOP=0
I $E(IOST,1,2)'["C-" Q
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="E" W ! D ^DIR
I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q
Q
;
UP(TEXT) ; Translate text to upper case
Q $$UP^XLFSTR($G(TEXT))
;
DATE(X,F) ; date in external format
I $G(F)="" S F="2Z" ; set date to return mm/dd/yy
Q $$FMTE^XLFDT(X,F)
;
NOW(F) ; Date/Time of right now in external format
S:$G(F)="" F=1 ; Date format Mon dd, yyyy@hh:mm:ss see kernel documentation
Q $$FMTE^XLFDT($$NOW^XLFDT,F)
;
VAL(XF,CODE) ; Validate a range or list of CARC (345), RARC (346) or PLB (345.1) Codes
; If invalid code is found VAILD = 0 and CODE will contain the offending codes
N VALID,ELEM,I,RNG1,RNG2,O1,O2,NWCD,RET S RET=""
S VALID=1,NWCD=$TR(CODE,";",":"),NWCD=$TR(NWCD,"-",":") ; Fix ";" or "-" to ":" (colons) for parsing
F I=1:1 S ELEM=$P(NWCD,",",I) Q:ELEM="" D
.; Is this a single code or range:
.I $L(ELEM,":")>2 S VALID=0,RET=$$PUSH(.RET,ELEM) Q
.I ELEM[":" D Q ; Range
..S RNG1=$P(ELEM,":",1),RNG2=$P(ELEM,":",2)
..;Lookup the codes
..S O1=$O(^RC(XF,"B",RNG1),-1),O1=$O(^RC(XF,"B",O1))
..S O2=$O(^RC(XF,"B",RNG2),-1),O2=$O(^RC(XF,"B",O2))
..I RNG1'=O1 S VALID=0,RET=$$PUSH(.RET,RNG1)
..I RNG2'=O2 S VALID=0,RET=$$PUSH(.RET,RNG2)
.E D
..;Validate individual items
..S O1=$O(^RC(XF,"B",ELEM),-1),O1=$O(^RC(XF,"B",O1))
..I ELEM'=O1 S VALID=0,RET=$$PUSH(.RET,ELEM)
;
S:VALID CODE=NWCD
S:'VALID CODE=RET
Q VALID
;
ACT(XF,CODE,DATE) ; Is the code active on Date
; If code is active return 1. If no date use today, date should be in fileman format.
N VALID,XIEN,XDT S VALID=0
I '$D(XF) Q VALID ; No file return 0
I $G(CODE)="" Q VALID ; No code return 0
S:'$D(DATE) DATE=$$DT^XLFDT
S XIEN=$$FIND1^DIC(XF,,"O",CODE)
I XIEN="" Q VALID ; No IEN for this code return 0
S XDT=$$GET1^DIQ(XF,XIEN_",",2,"I") ; Get date in FM format
S:XDT="" VALID=1 ; No stop date so it is active
I (XDT'="")&(XDT>DATE) S VALID=1
Q VALID
;
PUSH(VAR,VALUE) ;
Q:VAR="" VALUE ; Empty variable
Q VAR_U_VALUE
;
RNG(TYPE,ITEM,ARRAY) ; EP
; Collect data in a list or range to an array
; Input: TYPE - Type of data being collected
; CARC - Carc codes
; PAYER - Payer names
; PLB - Provider Level Balance Codes
; TIN - Payer IDs
; ITEM - Comma delimitted list of codes and/or ranges to parse
; Output: ARRAY - Array containing all of the data parsed from ITEM
I $G(ITEM)="ALL"!($G(ITEM)="A") S ARRAY(TYPE)="ALL" Q
N DELIM,ELEM,I,NW,X1,X2
;
; Before processing CARC and PLB Codes, translate any dashes found in ranges
; to colons
I TYPE'="PAYER",TYPE'="TIN" D
. S NW=$TR(ITEM,";",":"),NW=$TR(NW,"-",":"),DELIM=":"
E D ;
. S NW=ITEM
. S DELIM="~:~"
;
; Process each code or range int the comma delimitted list
F I=1:1 S ELEM=$P(NW,",",I) Q:ELEM="" D
. ; Single element set into array
. I ELEM'[DELIM S ARRAY(TYPE,ELEM)=1 Q
. D RNGIT(TYPE,ELEM,DELIM,.ARRAY)
Q
;
RNGIT(TYPE,ITEM,DELIM,ZAR) ; Process ranges for CARC/PLB/PAYER/TIN
; Input: TYPE - Type of data being collected
; CARC - Carc codes
; PAYER - Payer names
; PLB - Provider Level Balance Codes
; TIN - Payer IDs
; ITEM - Code or Code range being processed
; DELIM - Range delimitter to use
; Output: ZAR - Array containing all of the data parsed from ITEM
N ELEM,FILE,IDX,O1,X1,X2,ZGBL
;
; Set file # and index for the range lookup
S FILE=$S(TYPE="CARC":345,TYPE="PAYER":344.6,TYPE="TIN":344.6,TYPE="PLB":345.1,1:0)
S IDX=$S(TYPE="CARC":"B",TYPE="PAYER":"B",TYPE="TIN":"C",TYPE="PLB":"B",1:0)
;
; Get closed root of the Global
S ZGBL=$$ROOT^DILFD(FILE,"",1,"")
Q:ZGBL=""
;
; Process range of things in ITEM
S X1=$P(ITEM,DELIM,1),X2=$P(ITEM,DELIM,2)
S O1=$O(@ZGBL@(IDX,X1),-1) ; Set the start
F S O1=$O(@ZGBL@(IDX,O1)) Q:(O1="")!($$AFTER(O1,X2)) S ZAR(TYPE,O1)=1
Q
;
AFTER(ZZ1,ZZ2) ; Is ZZ1 after (or collates after) ZZ2
N XZ1,XZ2
S XZ1=+ZZ1,XZ2=+ZZ2
I (XZ1'=0)&(XZ2'=0) Q (XZ1>XZ2) ; Numeric
I (XZ1=0)&(XZ2'=0) Q 1 ; XZ1 not numeric, XZ2 numeric, XZ1 is after XZ2
I (XZ1=0)&(XZ2=0) Q (ZZ1]ZZ2) ; Both not numeric see if XZ1 collates after XZ2
Q 1 ; Default to after
;
GLIST(FILE,IDX,GLARR) ;Build list for this file
; Build list of available payers
N CNT,RCPAY S CNT=0,RCPAY=""
F S RCPAY=$O(^RCY(FILE,IDX,RCPAY)) Q:RCPAY="" D
.S CNT=CNT+1
.S @GLARR@(CNT)=RCPAY
.S @GLARR@(IDX,RCPAY,CNT)=""
;
Q
;
GETPAY(RCPAY) ; EP
; Get selected payers using file 344.6
; Note: Similar to GETPAY^RCDPEM9 except that method uses 344.4 or 344.31
; Input: None
; Output: RCPAY - ALL if all payers selected
; RCPAY(DATA) - 'ALL' - all payers selected
; Returns: 1 - Payer selection made, 0 otherwise
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,EX,RCLPAY,Y
S EX=1 ; Exit status
S DIR("A")="Select (A)ll or (R)ange of 835 Payer Names?: "
S DIR(0)="SA^A:All Payer Names;R:Range or List of Payer Names"
S DIR("B")="ALL"
D ^DIR
K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") S EX=0 Q EX
S RCLPAY=Y
I $G(Y)="A" S RCPAY="ALL",RCPAY("DATA")="ALL" Q EX
;
; Get Range of 835 Payers
I RCLPAY="R" S EX=$$GETRNG(.RCPAY,"P"),RCPAY="R"
Q EX
;
GETTIN(RCTIN) ; EP
; Get selected Payer TINs
; Input: None
; Output: RCTIN - ALL if all payer TINs selected
; RCPAY(DATA) - 'ALL' - all payer TINs selected
; Returns: 1 - Payer selection made, 0 otherwise
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,EX,RCTLIST,X,Y
S EX=1 ; Exit status
S DIR("A")="Select (A)ll or (R)ange of 835 Payer TINs?: "
S DIR(0)="SA^A:All Payer TINs;R:Range or List of Payer TINs"
S DIR("B")="ALL"
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") S EX=0 Q EX
S RCTLIST=Y
I $G(Y)="A" S RCTIN="ALL",RCTIN("DATA")="ALL" Q EX
;
; Get Range of 835 Payer TINs
I RCTLIST="R" S EX=$$GETRNG(.RCTIN,"T"),RCTIN="R"
Q EX
;
GETRNG(RTNARR,TYPE) ; Allows the user to specify a payer name or TIN range
; Input: TYPE - 'P' - Payer Name range selection
; 'T' - Payer TIN range selection
; Output: RTNARR - 'ERROR' - Invalid TYPE of range selected
; RTNARR(DATA) - A1~:~A2 Where:
; A1 - External Payer Name or TIN of selected
; 344.6 Payer for range start
; A2 - External Payer Name or TIN of selected
; 344.6 Payer for range end
; RTNARR(START) - Starting Range Value A1^A2^A3^A4 Where:
; A1 - Internal IEN of selected 344.6 Payer for
; range start
; A2 - External Payer Name or TIN for range start
; A3 - Internal IEN of selected 344.6 Payer for
; range start
; A4 - External Payer Name or TIN for range end
; RTNARR(END) - Ending Range Value A1^A2^A3^A4 Where:
; A1 - Internal IEN of selected 344.6 Payer for
; range end
; A2 - External Payer Name or TIN for range end
; A3 - Internal IEN of selected 344.6 for range end
; A4 - External Payer Name or TIN for range end
N D,DIC,DIROUT,DIRUT,DTOUT,DUOUT,IDX,RCDTN,RCDN,RCPT,X,Y
I $G(TYPE)=""!("PT"'[$G(TYPE)) S RTNARR="ERROR" Q ; Quit if TYPE not correct
S IDX=$S(TYPE="P":"B",TYPE="T":"C")
K DIC
S DIC="^RCY(344.6,",DIC(0)="AES",D=IDX
S DIC("A")="Start with 835 "_$S(TYPE="P":"Payer Name",TYPE="T":"Payer TIN")_": "
I TYPE="P" S DIC("W")="D EN^DDIOL($P(^(0),U,2),,""?35"")"
E S DIC("W")="D EN^DDIOL($P(^(0),U,1),,""?35"")"
D IX^DIC
I $D(DTOUT)!$D(DUOUT)!(Y="")!(Y=-1) Q 0
S RCDN=$O(^RCY(344.6,IDX,X,""))
S RTNARR("START")=RCDN_U_X_U_Y,RTNARR("DATA")=X
;
K DIC
S DIC="^RCY(344.6,",DIC(0)="AES",D=IDX
S DIC("A")="Go to with 835 "_$S(TYPE="P":"Payer Name",TYPE="T":"Payer TIN")_": "
I TYPE="P" S DIC("W")="D EN^DDIOL($P(^(0),U,2),,""?35"")"
E S DIC("W")="D EN^DDIOL($P(^(0),U,1),,""?35"")"
D IX^DIC
I $D(DTOUT)!$D(DUOUT)!(Y="")!(Y=-1) Q 0
S RCDN=$O(^RCY(344.6,IDX,X,""))
S RTNARR("END")=RCDN_U_X_U_Y
I TYPE="P" S RTNARR("DATA")=$P(RTNARR("START"),U,4)_"~:~"_$P(RTNARR("END"),U,4) ;PCRA*4.5*321
I TYPE="T" S RTNARR("DATA")=$P(RTNARR("START"),U,2)_"~:~"_$P(RTNARR("END"),U,2) ;PCRA*4.5*321
Q 1
;
CHECKDT(GSTART,GSTOP,GFILE) ; See if we have any possible data to report
N SDT,IEN,PTR,COUNT,RCGX
S COUNT=0
I GFILE=361.1 D
. S SDT=GSTART-0.001
. F S SDT=$O(^IBM(361.1,"E",SDT)) Q:(SDT="")!(SDT>GSTOP)!(COUNT>0) S COUNT=COUNT+1
I GFILE=344.4 D
. S SDT=GSTART-.001
. F S SDT=$O(^RCY(344.4,"AC",SDT)) Q:(SDT="")!(SDT>GSTOP)!(COUNT>0) D
.. S IEN="" F S IEN=$O(^RCY(344.4,"AC",SDT,IEN)) Q:IEN="" D
... K RCGX D GETS^DIQ(344.4,IEN_",","2*;","E","RCGX") Q:$D(RCGX)=0
... S COUNT=COUNT+1 ; We have at least 1 ERA with a PLB
Q COUNT
;
; RARR - Report array to walk; SUBS - Subscript to walk to sum the report
; ZSORT - Sorting on PLB Codes "C" or Payer/TIN "P"
SUMIT(RARR,SUBS,ZSORT) ; Summarize data in the array reference for PLB Report
N LVL2,ZZ,XX,ZAD,ZCO,ZDC,ZN,ZPAT,ZPD,ZT,ZC,ZCT,ZS,ZTOT,YY,QQ,OLD,TADJ,ZIDX
S ZT=0,ZC=0,ZTOT=0,ZAD=0,ZCO="",OLD=""
I $G(SUBS)="" Q ; We should always have this Variable
S ZZ="",ZCT=0,ZAD=0
; Walk the collection in "ERA" or "PAYR" this will have all of the ERAs for this report and summarize
F S ZZ=$O(@RARR@(SUBS,ZZ)) Q:ZZ="" D
. K ZCT S XX="",ZCT=0,ZTOT=0,ZAD=0,ZPD=0,ZDC=""
. ; XX will be the IEN of the ERA to count.
. F S XX=$O(@RARR@(SUBS,ZZ,XX)) Q:XX="" S ZN=@RARR@(SUBS,ZZ,XX,0),ZPD=ZPD+$P(ZN,U,5),ZPAT=$P(ZN,U,6)_"/"_$P(ZN,U,3) D
.. S ZCT=ZCT+1 S:ZSORT="C" ZCT(ZPAT)=$G(ZCT(ZPAT))+1,ZPD(ZZ_ZPAT)=$G(ZPD(ZZ_ZPAT))+$P(ZN,U,5) ; Count the ERAs and get paid for this payer
.. S ZTOT=+$G(@RARR@("00_ERA",XX,.1))
.. ; Get the adjusted amounts for the PLB codes (in ZZ if by Code)
.. I ZSORT="C" S ZAD=$$TAMT(XX,RARR,ZZ),ZDC=$$TCD(XX,RARR,ZZ)
.. I ZSORT="P" S YY=0.11 F S YY=$O(@RARR@("00_ERA",XX,YY)) Q:YY="" D
... ; Get PLB Code, Adjusted amt and Code Description for By Payer summary
... N QPD S QPD=0,ZCO=$P($G(@RARR@("00_ERA",XX,YY)),U,1),QPD("ADJ")=$P($G(@RARR@("00_ERA",XX,YY)),U,2),ZDC=$P($G(@RARR@("00_ERA",XX,YY)),U,4)
... S QPD=$G(@RARR@("SUMMARY",ZZ,ZCO)) ; existing data for this PLB Code (QPD)
... I ($G(OLD(ZZ,ZCO,XX))'=1) S QPD("PAID")=$P(QPD,U,2)+$P(ZN,U,5),QPD("COUNT")=$P(QPD,U,3)+1,QPD("TBILLED")=$P(QPD,U,5)+ZTOT
... E S QPD("PAID")=$P(QPD,U,2),QPD("COUNT")=$P(QPD,U,3),QPD("TBILLED")=$P(QPD,U,5)
... ; Adj Amt ^ Paid ^ Count of ERAs ^ Description ^ Total Billed
... S ZAD=($P(QPD,U,1)+QPD("ADJ")),ZPD=QPD("PAID"),ZCT=QPD("COUNT"),ZTOT=QPD("TBILLED")
... S @RARR@("SUMMARY",ZZ,ZCO)=ZAD_U_ZPD_U_ZCT_U_ZDC_U_ZTOT
... S OLD(ZZ,ZCO,XX)=1
.. S LVL2=$S(ZSORT="C":ZPAT,ZSORT="P":ZCO,1:XX)
.. S:ZSORT="C" ZAD=ZAD+$P($G(@RARR@("SUMMARY",ZZ,LVL2)),U,1),ZTOT=ZTOT+$P($G(@RARR@("SUMMARY",ZZ,LVL2)),U,5) ; Sum the ADJ & BILLED amounts
.. ; Adj Amt ^ Paid ^ Count of ERAs ^ ^ Total Billed
.. I ZSORT="C" S @RARR@("SUMMARY",ZZ,LVL2)=ZAD_U_ZPD(ZZ_ZPAT)_U_ZCT(ZPAT)_U_U_ZTOT
;
; Summarize the Code level totals
I ZSORT="C" K OLD S ZZ="",QQ="" F S ZZ=$O(@RARR@("ERA",ZZ)) Q:ZZ="" D
. S QQ="",(ZCT,ZPD,ZAD,ZTOT)=0 F S QQ=$O(@RARR@("ERA",ZZ,QQ)) Q:QQ="" D
.. S ZCT=ZCT+1
.. S ZPD=ZPD+$P(@RARR@("ERA",ZZ,QQ,0),U,5),ZTOT=ZTOT+@RARR@("00_ERA",QQ,.1),ZAD=ZAD+$$TAMT(QQ,RARR,ZZ),ZDC=$$TCD(QQ,RARR,ZZ)
. S @RARR@("SUMMARY",ZZ)=ZAD_U_ZPD_U_ZCT_U_ZDC_U_ZTOT
;
; Summarize the Payer level totals
I ZSORT="P" K OLD S ZZ="",QQ="" F S ZZ=$O(@RARR@("PAYR",ZZ)) Q:ZZ="" D
. S QQ="",(ZCT,ZPD,ZAD,ZTOT)=0 F S QQ=$O(@RARR@("PAYR",ZZ,QQ)) Q:QQ="" D
.. S ZCT=ZCT+1
.. S ZPD=ZPD+$P(@RARR@("PAYR",ZZ,QQ,0),U,5),ZTOT=ZTOT+@RARR@("00_ERA",QQ,.1),ZAD=ZAD+$$TAMT(QQ,RARR,"")
. S @RARR@("SUMMARY",ZZ)=ZAD_U_ZPD_U_ZCT_U_U_ZTOT
;
; Collect and summarize the Grand Totals.
S ZZ="",QQ="" F S ZZ=$O(@RARR@(SUBS,ZZ)) Q:ZZ="" D
. S XX="" F S XX=$O(@RARR@(SUBS,ZZ,XX)) Q:XX="" S ZT=$G(@RARR@("TOTALS")),ZS=$G(@RARR@("SUMMARY",ZZ)) D S @RARR@("ZZ_COUNTED",XX)=1
.. S ZN=$G(@RARR@(SUBS,ZZ,XX,0)),ZN("TBILLED")=@RARR@("00_ERA",XX,.1),TADJ=$$TAMT(XX,RARR,"")
.. I $G(@RARR@("ZZ_COUNTED",XX))'=1 D
... S @RARR@("TOTALS")=($P(ZT,U,1)+TADJ)_U_($P(ZT,U,2)+$P(ZN,U,5))_U_($P(ZT,U,3)+1)_U_U_($P(ZT,U,5)+ZN("TBILLED"))
Q
;
TAMT(ZIEN,XGBL,ZCODE) ; Get Adjustment Amounts
N ZAMT,XDN,AA S ZAMT=0
; ZCODE if defined is get the Adjustment amounts for just this code
; otherwise sum the adjustment amounts for this ERA in ZIEN
D
. S AA=0.1 F S AA=$O(@XGBL@("00_ERA",ZIEN,AA)) Q:AA="" D
.. I $G(ZCODE)'="" Q:$P($G(@XGBL@("00_ERA",ZIEN,AA)),U,1)'=ZCODE ; Quit if we don't have the right code
.. ; Collect adjustment amounts to return for this ZIEN
.. S ZAMT=ZAMT+$P(@XGBL@("00_ERA",ZIEN,AA),U,2)
Q ZAMT
;
TCD(ZIEN,XGBL,ZCODE) ; Get PLB Description for Code & IEN given
N RET,AA S RET=""
Q:$G(ZCODE)="" ""
S AA=0.1 F S AA=$O(@XGBL@("00_ERA",ZIEN,AA)) Q:AA="" D Q:RET'=""
. Q:$P($G(@XGBL@("00_ERA",ZIEN,AA)),U,1)'=ZCODE ; Quit if we don't have the right code
. S RET=$P(@XGBL@("00_ERA",ZIEN,AA),U,4)
Q RET
;
; Moved from RCDPEM2 because of size issues
UPDERA(DA,RECEPT,FOUND) ;Mark ERA as posted to paper EOB
N Y,X,DR,DIE,%
D NOW^%DTC
S DIE="^RCY(344.4,",FOUND=0
;Update Receipt #, EFT Match Status, Detail Post Status and Paper EOB
S DR=".08///"_RECEPT_";.09///2;.14///2;20.03///1"
;Update Date/Time Posted and User fields
S DR=DR_";7.01///"_%_";7.02///"_DUZ
D ^DIE
I '$D(Y) D
.K DIR
.S DIR(0)="EA"
.S DIR("A",1)="ERA HAS BEEN MARKED AS POSTED USING PAPER EOB"
.S DIR("A")="Press ENTER to continue: " W ! D ^DIR K DIR
.S FOUND=1
E W !,"Unable to update ERA for receipt "_RECEPT,!
Q FOUND
;
; Get Reciept Date (moved from RCDPEM2
RCDATE(RECEPT) ;
N RCRECTDA
;Get receipt IEN
S RCRECTDA=$O(^RCY(344,"B",RECEPT,0)) Q:'RCRECTDA 0
;Return Receipt date
Q $P($G(^RCY(344,RCRECTDA,0)),U,3)
;
AMT(RECEPT) ;Total Receipt amount
N RCRECTDA,RCTRAN,RCTOT
;Get receipt IEN
S RCRECTDA=$O(^RCY(344,"B",RECEPT,0)) Q:'RCRECTDA 0
;Total the Receipt transactions
S RCTRAN=0,RCTOT=0
F S RCTRAN=$O(^RCY(344,RCRECTDA,1,RCTRAN)) Q:'RCTRAN D
.S RCTOT=RCTOT+$P($G(^RCY(344,RCRECTDA,1,RCTRAN,0)),U,4)
Q RCTOT
;
; Moved from RCDPEM2 for Manual match because RCDPEM2 was too big in size
; END, DTRNG, RCERA, RCMBG, START variables are newed and cleaned up in RCDPEM2
ML0() ;
ML0A S RCERA=$$SEL^RCDPEWL7() ; Select ERA to use from screen
S RCMBG=VALMBG ; Save the line, we need it when we go back to the worklist.
I RCERA=0 Q 1
S RCERA(0)=^RCY(344.4,RCERA,0) ; Get the zero node for this ERA
I ((+($P(RCERA(0),U,9)))>0)!($P(RCERA(0),U,8)'="") D Q 1 ; PRCA*4.5*326
. W !,"ERA is already matched please select another ERA..."
. D WAIT^VALM1
S DIR("A")="Select EFT by date Range? (Y/N) ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) Q 1
I Y<1 G MLQ ; Go to the EFT Selection
S DTRNG=Y ; flag indicating date range selected
K DIR S DIR("?")="Enter the earliest date for the selection range."
; value in DIR(0) for %DT = APE: ask date, past assumed, echo answer
S DIR(0)="DAO^:"_DT_":APE",DIR("A")="Start Date: " D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") Q 1
S START=Y K DIR,X,Y
S DIR("?")="Enter the latest date for the selection range."
S DIR(0)="DAO^"_START_":"_DT_":APE",DIR("A")="End Date: ",DIR("B")=$$FMTE^XLFDT(DT)
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") Q 1
S END=Y
;
MLQ Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPRU 17752 printed Oct 16, 2024@17:47:18 Page 2
RCDPRU ;ALB/TJB - CARC REPORT ON PAYER OR CARC CODE ;9/15/14 3:00pm
+1 ;;4.5;Accounts Receivable;**303,321,326**;Mar 20, 1995;Build 26
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ; PRCA*4.5*303 - CARC and Payer report utilities
+5 ; IA 594 - ACCOUNTS RECEIVABLE CATEGORY file (#430.2)
+6 ; IA 1077 - Using DIVISION^VAUTOMA to query for division
+7 ; IA 1992 - BILL/CLAIMS file (#399)
+8 ; IA 3820 - BILL/CLAIMS file (#399)
+9 ; IA 3822 - RATE TYPE file (#399.3)
+10 ; IA 4051 - EXPLANATION OF BENEFITS file (#361.1)
+11 ; IA 4996 - BILL/CLAIMS file (#399)
+12 ;
DISPTY() ; function, ask display/output type
+1 ; processes input from user
+2 ; returns: Output destination (0=Display, 1=MS Excel, -1=timeout or '^)
+3 NEW DIR,DUOUT,DIRUT,X,Y
+4 SET DIR(0)="YA"
SET DIR("A")="Export the report to Microsoft Excel? (Y/N): "
SET DIR("B")="NO"
+5 DO ^DIR
+6 IF $DATA(DUOUT)!$DATA(DIRUT)
SET Y=-1
+7 QUIT Y
+8 ;
INFO ; Useful Info for Excel capture
+1 ; spaces
NEW SP
SET SP=$JUSTIFY(" ",10)
+2 WRITE !!!,SP_"Before continuing, please set up your terminal to capture the"
+3 WRITE !,SP_"report data as this report may take a while to run."
+4 WRITE !!,SP_"To avoid undesired wrapping of the data saved to the"
+5 WRITE !,SP_"file, please enter '0;256;999' at the 'DEVICE:' prompt."
+6 WRITE !!,SP_"It may be necessary to set the terminal's display width"
+7 WRITE !,SP_"to 256 characters, which can be performed by selecting the"
+8 WRITE !,SP_"Display option located within the 'Setup' menu on the"
+9 WRITE !,SP_"tool bar of the terminal emulation software (e.g. KEA,"
+10 WRITE !,SP_"Reflection, or Smarterm).",!!
+11 QUIT
+12 ;
ASK(RCSTOP) ; User if you want to quit or continue
+1 SET RCSTOP=0
+2 IF $EXTRACT(IOST,1,2)'["C-"
QUIT
+3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+4 SET DIR(0)="E"
WRITE !
DO ^DIR
+5 IF ($DATA(DIRUT))!($DATA(DUOUT))
SET RCSTOP=1
QUIT
+6 QUIT
+7 ;
UP(TEXT) ; Translate text to upper case
+1 QUIT $$UP^XLFSTR($GET(TEXT))
+2 ;
DATE(X,F) ; date in external format
+1 ; set date to return mm/dd/yy
IF $GET(F)=""
SET F="2Z"
+2 QUIT $$FMTE^XLFDT(X,F)
+3 ;
NOW(F) ; Date/Time of right now in external format
+1 ; Date format Mon dd, yyyy@hh:mm:ss see kernel documentation
if $GET(F)=""
SET F=1
+2 QUIT $$FMTE^XLFDT($$NOW^XLFDT,F)
+3 ;
VAL(XF,CODE) ; Validate a range or list of CARC (345), RARC (346) or PLB (345.1) Codes
+1 ; If invalid code is found VAILD = 0 and CODE will contain the offending codes
+2 NEW VALID,ELEM,I,RNG1,RNG2,O1,O2,NWCD,RET
SET RET=""
+3 ; Fix ";" or "-" to ":" (colons) for parsing
SET VALID=1
SET NWCD=$TRANSLATE(CODE,";",":")
SET NWCD=$TRANSLATE(NWCD,"-",":")
+4 FOR I=1:1
SET ELEM=$PIECE(NWCD,",",I)
if ELEM=""
QUIT
Begin DoDot:1
+5 ; Is this a single code or range:
+6 IF $LENGTH(ELEM,":")>2
SET VALID=0
SET RET=$$PUSH(.RET,ELEM)
QUIT
+7 ; Range
IF ELEM[":"
Begin DoDot:2
+8 SET RNG1=$PIECE(ELEM,":",1)
SET RNG2=$PIECE(ELEM,":",2)
+9 ;Lookup the codes
+10 SET O1=$ORDER(^RC(XF,"B",RNG1),-1)
SET O1=$ORDER(^RC(XF,"B",O1))
+11 SET O2=$ORDER(^RC(XF,"B",RNG2),-1)
SET O2=$ORDER(^RC(XF,"B",O2))
+12 IF RNG1'=O1
SET VALID=0
SET RET=$$PUSH(.RET,RNG1)
+13 IF RNG2'=O2
SET VALID=0
SET RET=$$PUSH(.RET,RNG2)
End DoDot:2
QUIT
+14 IF '$TEST
Begin DoDot:2
+15 ;Validate individual items
+16 SET O1=$ORDER(^RC(XF,"B",ELEM),-1)
SET O1=$ORDER(^RC(XF,"B",O1))
+17 IF ELEM'=O1
SET VALID=0
SET RET=$$PUSH(.RET,ELEM)
End DoDot:2
End DoDot:1
+18 ;
+19 if VALID
SET CODE=NWCD
+20 if 'VALID
SET CODE=RET
+21 QUIT VALID
+22 ;
ACT(XF,CODE,DATE) ; Is the code active on Date
+1 ; If code is active return 1. If no date use today, date should be in fileman format.
+2 NEW VALID,XIEN,XDT
SET VALID=0
+3 ; No file return 0
IF '$DATA(XF)
QUIT VALID
+4 ; No code return 0
IF $GET(CODE)=""
QUIT VALID
+5 if '$DATA(DATE)
SET DATE=$$DT^XLFDT
+6 SET XIEN=$$FIND1^DIC(XF,,"O",CODE)
+7 ; No IEN for this code return 0
IF XIEN=""
QUIT VALID
+8 ; Get date in FM format
SET XDT=$$GET1^DIQ(XF,XIEN_",",2,"I")
+9 ; No stop date so it is active
if XDT=""
SET VALID=1
+10 IF (XDT'="")&(XDT>DATE)
SET VALID=1
+11 QUIT VALID
+12 ;
PUSH(VAR,VALUE) ;
+1 ; Empty variable
if VAR=""
QUIT VALUE
+2 QUIT VAR_U_VALUE
+3 ;
RNG(TYPE,ITEM,ARRAY) ; EP
+1 ; Collect data in a list or range to an array
+2 ; Input: TYPE - Type of data being collected
+3 ; CARC - Carc codes
+4 ; PAYER - Payer names
+5 ; PLB - Provider Level Balance Codes
+6 ; TIN - Payer IDs
+7 ; ITEM - Comma delimitted list of codes and/or ranges to parse
+8 ; Output: ARRAY - Array containing all of the data parsed from ITEM
+9 IF $GET(ITEM)="ALL"!($GET(ITEM)="A")
SET ARRAY(TYPE)="ALL"
QUIT
+10 NEW DELIM,ELEM,I,NW,X1,X2
+11 ;
+12 ; Before processing CARC and PLB Codes, translate any dashes found in ranges
+13 ; to colons
+14 IF TYPE'="PAYER"
IF TYPE'="TIN"
Begin DoDot:1
+15 SET NW=$TRANSLATE(ITEM,";",":")
SET NW=$TRANSLATE(NW,"-",":")
SET DELIM=":"
End DoDot:1
+16 ;
IF '$TEST
Begin DoDot:1
+17 SET NW=ITEM
+18 SET DELIM="~:~"
End DoDot:1
+19 ;
+20 ; Process each code or range int the comma delimitted list
+21 FOR I=1:1
SET ELEM=$PIECE(NW,",",I)
if ELEM=""
QUIT
Begin DoDot:1
+22 ; Single element set into array
+23 IF ELEM'[DELIM
SET ARRAY(TYPE,ELEM)=1
QUIT
+24 DO RNGIT(TYPE,ELEM,DELIM,.ARRAY)
End DoDot:1
+25 QUIT
+26 ;
RNGIT(TYPE,ITEM,DELIM,ZAR) ; Process ranges for CARC/PLB/PAYER/TIN
+1 ; Input: TYPE - Type of data being collected
+2 ; CARC - Carc codes
+3 ; PAYER - Payer names
+4 ; PLB - Provider Level Balance Codes
+5 ; TIN - Payer IDs
+6 ; ITEM - Code or Code range being processed
+7 ; DELIM - Range delimitter to use
+8 ; Output: ZAR - Array containing all of the data parsed from ITEM
+9 NEW ELEM,FILE,IDX,O1,X1,X2,ZGBL
+10 ;
+11 ; Set file # and index for the range lookup
+12 SET FILE=$SELECT(TYPE="CARC":345,TYPE="PAYER":344.6,TYPE="TIN":344.6,TYPE="PLB":345.1,1:0)
+13 SET IDX=$SELECT(TYPE="CARC":"B",TYPE="PAYER":"B",TYPE="TIN":"C",TYPE="PLB":"B",1:0)
+14 ;
+15 ; Get closed root of the Global
+16 SET ZGBL=$$ROOT^DILFD(FILE,"",1,"")
+17 if ZGBL=""
QUIT
+18 ;
+19 ; Process range of things in ITEM
+20 SET X1=$PIECE(ITEM,DELIM,1)
SET X2=$PIECE(ITEM,DELIM,2)
+21 ; Set the start
SET O1=$ORDER(@ZGBL@(IDX,X1),-1)
+22 FOR
SET O1=$ORDER(@ZGBL@(IDX,O1))
if (O1="")!($$AFTER(O1,X2))
QUIT
SET ZAR(TYPE,O1)=1
+23 QUIT
+24 ;
AFTER(ZZ1,ZZ2) ; Is ZZ1 after (or collates after) ZZ2
+1 NEW XZ1,XZ2
+2 SET XZ1=+ZZ1
SET XZ2=+ZZ2
+3 ; Numeric
IF (XZ1'=0)&(XZ2'=0)
QUIT (XZ1>XZ2)
+4 ; XZ1 not numeric, XZ2 numeric, XZ1 is after XZ2
IF (XZ1=0)&(XZ2'=0)
QUIT 1
+5 ; Both not numeric see if XZ1 collates after XZ2
IF (XZ1=0)&(XZ2=0)
QUIT (ZZ1]ZZ2)
+6 ; Default to after
QUIT 1
+7 ;
GLIST(FILE,IDX,GLARR) ;Build list for this file
+1 ; Build list of available payers
+2 NEW CNT,RCPAY
SET CNT=0
SET RCPAY=""
+3 FOR
SET RCPAY=$ORDER(^RCY(FILE,IDX,RCPAY))
if RCPAY=""
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
+5 SET @GLARR@(CNT)=RCPAY
+6 SET @GLARR@(IDX,RCPAY,CNT)=""
End DoDot:1
+7 ;
+8 QUIT
+9 ;
GETPAY(RCPAY) ; EP
+1 ; Get selected payers using file 344.6
+2 ; Note: Similar to GETPAY^RCDPEM9 except that method uses 344.4 or 344.31
+3 ; Input: None
+4 ; Output: RCPAY - ALL if all payers selected
+5 ; RCPAY(DATA) - 'ALL' - all payers selected
+6 ; Returns: 1 - Payer selection made, 0 otherwise
+7 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,EX,RCLPAY,Y
+8 ; Exit status
SET EX=1
+9 SET DIR("A")="Select (A)ll or (R)ange of 835 Payer Names?: "
+10 SET DIR(0)="SA^A:All Payer Names;R:Range or List of Payer Names"
+11 SET DIR("B")="ALL"
+12 DO ^DIR
+13 KILL DIR
+14 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET EX=0
QUIT EX
+15 SET RCLPAY=Y
+16 IF $GET(Y)="A"
SET RCPAY="ALL"
SET RCPAY("DATA")="ALL"
QUIT EX
+17 ;
+18 ; Get Range of 835 Payers
+19 IF RCLPAY="R"
SET EX=$$GETRNG(.RCPAY,"P")
SET RCPAY="R"
+20 QUIT EX
+21 ;
GETTIN(RCTIN) ; EP
+1 ; Get selected Payer TINs
+2 ; Input: None
+3 ; Output: RCTIN - ALL if all payer TINs selected
+4 ; RCPAY(DATA) - 'ALL' - all payer TINs selected
+5 ; Returns: 1 - Payer selection made, 0 otherwise
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,EX,RCTLIST,X,Y
+7 ; Exit status
SET EX=1
+8 SET DIR("A")="Select (A)ll or (R)ange of 835 Payer TINs?: "
+9 SET DIR(0)="SA^A:All Payer TINs;R:Range or List of Payer TINs"
+10 SET DIR("B")="ALL"
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET EX=0
QUIT EX
+13 SET RCTLIST=Y
+14 IF $GET(Y)="A"
SET RCTIN="ALL"
SET RCTIN("DATA")="ALL"
QUIT EX
+15 ;
+16 ; Get Range of 835 Payer TINs
+17 IF RCTLIST="R"
SET EX=$$GETRNG(.RCTIN,"T")
SET RCTIN="R"
+18 QUIT EX
+19 ;
GETRNG(RTNARR,TYPE) ; Allows the user to specify a payer name or TIN range
+1 ; Input: TYPE - 'P' - Payer Name range selection
+2 ; 'T' - Payer TIN range selection
+3 ; Output: RTNARR - 'ERROR' - Invalid TYPE of range selected
+4 ; RTNARR(DATA) - A1~:~A2 Where:
+5 ; A1 - External Payer Name or TIN of selected
+6 ; 344.6 Payer for range start
+7 ; A2 - External Payer Name or TIN of selected
+8 ; 344.6 Payer for range end
+9 ; RTNARR(START) - Starting Range Value A1^A2^A3^A4 Where:
+10 ; A1 - Internal IEN of selected 344.6 Payer for
+11 ; range start
+12 ; A2 - External Payer Name or TIN for range start
+13 ; A3 - Internal IEN of selected 344.6 Payer for
+14 ; range start
+15 ; A4 - External Payer Name or TIN for range end
+16 ; RTNARR(END) - Ending Range Value A1^A2^A3^A4 Where:
+17 ; A1 - Internal IEN of selected 344.6 Payer for
+18 ; range end
+19 ; A2 - External Payer Name or TIN for range end
+20 ; A3 - Internal IEN of selected 344.6 for range end
+21 ; A4 - External Payer Name or TIN for range end
+22 NEW D,DIC,DIROUT,DIRUT,DTOUT,DUOUT,IDX,RCDTN,RCDN,RCPT,X,Y
+23 ; Quit if TYPE not correct
IF $GET(TYPE)=""!("PT"'[$GET(TYPE))
SET RTNARR="ERROR"
QUIT
+24 SET IDX=$SELECT(TYPE="P":"B",TYPE="T":"C")
+25 KILL DIC
+26 SET DIC="^RCY(344.6,"
SET DIC(0)="AES"
SET D=IDX
+27 SET DIC("A")="Start with 835 "_$SELECT(TYPE="P":"Payer Name",TYPE="T":"Payer TIN")_": "
+28 IF TYPE="P"
SET DIC("W")="D EN^DDIOL($P(^(0),U,2),,""?35"")"
+29 IF '$TEST
SET DIC("W")="D EN^DDIOL($P(^(0),U,1),,""?35"")"
+30 DO IX^DIC
+31 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")!(Y=-1)
QUIT 0
+32 SET RCDN=$ORDER(^RCY(344.6,IDX,X,""))
+33 SET RTNARR("START")=RCDN_U_X_U_Y
SET RTNARR("DATA")=X
+34 ;
+35 KILL DIC
+36 SET DIC="^RCY(344.6,"
SET DIC(0)="AES"
SET D=IDX
+37 SET DIC("A")="Go to with 835 "_$SELECT(TYPE="P":"Payer Name",TYPE="T":"Payer TIN")_": "
+38 IF TYPE="P"
SET DIC("W")="D EN^DDIOL($P(^(0),U,2),,""?35"")"
+39 IF '$TEST
SET DIC("W")="D EN^DDIOL($P(^(0),U,1),,""?35"")"
+40 DO IX^DIC
+41 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")!(Y=-1)
QUIT 0
+42 SET RCDN=$ORDER(^RCY(344.6,IDX,X,""))
+43 SET RTNARR("END")=RCDN_U_X_U_Y
+44 ;PCRA*4.5*321
IF TYPE="P"
SET RTNARR("DATA")=$PIECE(RTNARR("START"),U,4)_"~:~"_$PIECE(RTNARR("END"),U,4)
+45 ;PCRA*4.5*321
IF TYPE="T"
SET RTNARR("DATA")=$PIECE(RTNARR("START"),U,2)_"~:~"_$PIECE(RTNARR("END"),U,2)
+46 QUIT 1
+47 ;
CHECKDT(GSTART,GSTOP,GFILE) ; See if we have any possible data to report
+1 NEW SDT,IEN,PTR,COUNT,RCGX
+2 SET COUNT=0
+3 IF GFILE=361.1
Begin DoDot:1
+4 SET SDT=GSTART-0.001
+5 FOR
SET SDT=$ORDER(^IBM(361.1,"E",SDT))
if (SDT="")!(SDT>GSTOP)!(COUNT>0)
QUIT
SET COUNT=COUNT+1
End DoDot:1
+6 IF GFILE=344.4
Begin DoDot:1
+7 SET SDT=GSTART-.001
+8 FOR
SET SDT=$ORDER(^RCY(344.4,"AC",SDT))
if (SDT="")!(SDT>GSTOP)!(COUNT>0)
QUIT
Begin DoDot:2
+9 SET IEN=""
FOR
SET IEN=$ORDER(^RCY(344.4,"AC",SDT,IEN))
if IEN=""
QUIT
Begin DoDot:3
+10 KILL RCGX
DO GETS^DIQ(344.4,IEN_",","2*;","E","RCGX")
if $DATA(RCGX)=0
QUIT
+11 ; We have at least 1 ERA with a PLB
SET COUNT=COUNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT COUNT
+13 ;
+14 ; RARR - Report array to walk; SUBS - Subscript to walk to sum the report
+15 ; ZSORT - Sorting on PLB Codes "C" or Payer/TIN "P"
SUMIT(RARR,SUBS,ZSORT) ; Summarize data in the array reference for PLB Report
+1 NEW LVL2,ZZ,XX,ZAD,ZCO,ZDC,ZN,ZPAT,ZPD,ZT,ZC,ZCT,ZS,ZTOT,YY,QQ,OLD,TADJ,ZIDX
+2 SET ZT=0
SET ZC=0
SET ZTOT=0
SET ZAD=0
SET ZCO=""
SET OLD=""
+3 ; We should always have this Variable
IF $GET(SUBS)=""
QUIT
+4 SET ZZ=""
SET ZCT=0
SET ZAD=0
+5 ; Walk the collection in "ERA" or "PAYR" this will have all of the ERAs for this report and summarize
+6 FOR
SET ZZ=$ORDER(@RARR@(SUBS,ZZ))
if ZZ=""
QUIT
Begin DoDot:1
+7 KILL ZCT
SET XX=""
SET ZCT=0
SET ZTOT=0
SET ZAD=0
SET ZPD=0
SET ZDC=""
+8 ; XX will be the IEN of the ERA to count.
+9 FOR
SET XX=$ORDER(@RARR@(SUBS,ZZ,XX))
if XX=""
QUIT
SET ZN=@RARR@(SUBS,ZZ,XX,0)
SET ZPD=ZPD+$PIECE(ZN,U,5)
SET ZPAT=$PIECE(ZN,U,6)_"/"_$PIECE(ZN,U,3)
Begin DoDot:2
+10 ; Count the ERAs and get paid for this payer
SET ZCT=ZCT+1
if ZSORT="C"
SET ZCT(ZPAT)=$GET(ZCT(ZPAT))+1
SET ZPD(ZZ_ZPAT)=$GET(ZPD(ZZ_ZPAT))+$PIECE(ZN,U,5)
+11 SET ZTOT=+$GET(@RARR@("00_ERA",XX,.1))
+12 ; Get the adjusted amounts for the PLB codes (in ZZ if by Code)
+13 IF ZSORT="C"
SET ZAD=$$TAMT(XX,RARR,ZZ)
SET ZDC=$$TCD(XX,RARR,ZZ)
+14 IF ZSORT="P"
SET YY=0.11
FOR
SET YY=$ORDER(@RARR@("00_ERA",XX,YY))
if YY=""
QUIT
Begin DoDot:3
+15 ; Get PLB Code, Adjusted amt and Code Description for By Payer summary
+16 NEW QPD
SET QPD=0
SET ZCO=$PIECE($GET(@RARR@("00_ERA",XX,YY)),U,1)
SET QPD("ADJ")=$PIECE($GET(@RARR@("00_ERA",XX,YY)),U,2)
SET ZDC=$PIECE($GET(@RARR@("00_ERA",XX,YY)),U,4)
+17 ; existing data for this PLB Code (QPD)
SET QPD=$GET(@RARR@("SUMMARY",ZZ,ZCO))
+18 IF ($GET(OLD(ZZ,ZCO,XX))'=1)
SET QPD("PAID")=$PIECE(QPD,U,2)+$PIECE(ZN,U,5)
SET QPD("COUNT")=$PIECE(QPD,U,3)+1
SET QPD("TBILLED")=$PIECE(QPD,U,5)+ZTOT
+19 IF '$TEST
SET QPD("PAID")=$PIECE(QPD,U,2)
SET QPD("COUNT")=$PIECE(QPD,U,3)
SET QPD("TBILLED")=$PIECE(QPD,U,5)
+20 ; Adj Amt ^ Paid ^ Count of ERAs ^ Description ^ Total Billed
+21 SET ZAD=($PIECE(QPD,U,1)+QPD("ADJ"))
SET ZPD=QPD("PAID")
SET ZCT=QPD("COUNT")
SET ZTOT=QPD("TBILLED")
+22 SET @RARR@("SUMMARY",ZZ,ZCO)=ZAD_U_ZPD_U_ZCT_U_ZDC_U_ZTOT
+23 SET OLD(ZZ,ZCO,XX)=1
End DoDot:3
+24 SET LVL2=$SELECT(ZSORT="C":ZPAT,ZSORT="P":ZCO,1:XX)
+25 ; Sum the ADJ & BILLED amounts
if ZSORT="C"
SET ZAD=ZAD+$PIECE($GET(@RARR@("SUMMARY",ZZ,LVL2)),U,1)
SET ZTOT=ZTOT+$PIECE($GET(@RARR@("SUMMARY",ZZ,LVL2)),U,5)
+26 ; Adj Amt ^ Paid ^ Count of ERAs ^ ^ Total Billed
+27 IF ZSORT="C"
SET @RARR@("SUMMARY",ZZ,LVL2)=ZAD_U_ZPD(ZZ_ZPAT)_U_ZCT(ZPAT)_U_U_ZTOT
End DoDot:2
End DoDot:1
+28 ;
+29 ; Summarize the Code level totals
+30 IF ZSORT="C"
KILL OLD
SET ZZ=""
SET QQ=""
FOR
SET ZZ=$ORDER(@RARR@("ERA",ZZ))
if ZZ=""
QUIT
Begin DoDot:1
+31 SET QQ=""
SET (ZCT,ZPD,ZAD,ZTOT)=0
FOR
SET QQ=$ORDER(@RARR@("ERA",ZZ,QQ))
if QQ=""
QUIT
Begin DoDot:2
+32 SET ZCT=ZCT+1
+33 SET ZPD=ZPD+$PIECE(@RARR@("ERA",ZZ,QQ,0),U,5)
SET ZTOT=ZTOT+@RARR@("00_ERA",QQ,.1)
SET ZAD=ZAD+$$TAMT(QQ,RARR,ZZ)
SET ZDC=$$TCD(QQ,RARR,ZZ)
End DoDot:2
+34 SET @RARR@("SUMMARY",ZZ)=ZAD_U_ZPD_U_ZCT_U_ZDC_U_ZTOT
End DoDot:1
+35 ;
+36 ; Summarize the Payer level totals
+37 IF ZSORT="P"
KILL OLD
SET ZZ=""
SET QQ=""
FOR
SET ZZ=$ORDER(@RARR@("PAYR",ZZ))
if ZZ=""
QUIT
Begin DoDot:1
+38 SET QQ=""
SET (ZCT,ZPD,ZAD,ZTOT)=0
FOR
SET QQ=$ORDER(@RARR@("PAYR",ZZ,QQ))
if QQ=""
QUIT
Begin DoDot:2
+39 SET ZCT=ZCT+1
+40 SET ZPD=ZPD+$PIECE(@RARR@("PAYR",ZZ,QQ,0),U,5)
SET ZTOT=ZTOT+@RARR@("00_ERA",QQ,.1)
SET ZAD=ZAD+$$TAMT(QQ,RARR,"")
End DoDot:2
+41 SET @RARR@("SUMMARY",ZZ)=ZAD_U_ZPD_U_ZCT_U_U_ZTOT
End DoDot:1
+42 ;
+43 ; Collect and summarize the Grand Totals.
+44 SET ZZ=""
SET QQ=""
FOR
SET ZZ=$ORDER(@RARR@(SUBS,ZZ))
if ZZ=""
QUIT
Begin DoDot:1
+45 SET XX=""
FOR
SET XX=$ORDER(@RARR@(SUBS,ZZ,XX))
if XX=""
QUIT
SET ZT=$GET(@RARR@("TOTALS"))
SET ZS=$GET(@RARR@("SUMMARY",ZZ))
Begin DoDot:2
+46 SET ZN=$GET(@RARR@(SUBS,ZZ,XX,0))
SET ZN("TBILLED")=@RARR@("00_ERA",XX,.1)
SET TADJ=$$TAMT(XX,RARR,"")
+47 IF $GET(@RARR@("ZZ_COUNTED",XX))'=1
Begin DoDot:3
+48 SET @RARR@("TOTALS")=($PIECE(ZT,U,1)+TADJ)_U_($PIECE(ZT,U,2)+$PIECE(ZN,U,5))_U_($PIECE(ZT,U,3)+1)_U_U_($PIECE(ZT,U,5)+ZN("TBILLED"))
End DoDot:3
End DoDot:2
SET @RARR@("ZZ_COUNTED",XX)=1
End DoDot:1
+49 QUIT
+50 ;
TAMT(ZIEN,XGBL,ZCODE) ; Get Adjustment Amounts
+1 NEW ZAMT,XDN,AA
SET ZAMT=0
+2 ; ZCODE if defined is get the Adjustment amounts for just this code
+3 ; otherwise sum the adjustment amounts for this ERA in ZIEN
+4 Begin DoDot:1
+5 SET AA=0.1
FOR
SET AA=$ORDER(@XGBL@("00_ERA",ZIEN,AA))
if AA=""
QUIT
Begin DoDot:2
+6 ; Quit if we don't have the right code
IF $GET(ZCODE)'=""
if $PIECE($GET(@XGBL@("00_ERA",ZIEN,AA)),U,1)'=ZCODE
QUIT
+7 ; Collect adjustment amounts to return for this ZIEN
+8 SET ZAMT=ZAMT+$PIECE(@XGBL@("00_ERA",ZIEN,AA),U,2)
End DoDot:2
End DoDot:1
+9 QUIT ZAMT
+10 ;
TCD(ZIEN,XGBL,ZCODE) ; Get PLB Description for Code & IEN given
+1 NEW RET,AA
SET RET=""
+2 if $GET(ZCODE)=""
QUIT ""
+3 SET AA=0.1
FOR
SET AA=$ORDER(@XGBL@("00_ERA",ZIEN,AA))
if AA=""
QUIT
Begin DoDot:1
+4 ; Quit if we don't have the right code
if $PIECE($GET(@XGBL@("00_ERA",ZIEN,AA)),U,1)'=ZCODE
QUIT
+5 SET RET=$PIECE(@XGBL@("00_ERA",ZIEN,AA),U,4)
End DoDot:1
if RET'=""
QUIT
+6 QUIT RET
+7 ;
+8 ; Moved from RCDPEM2 because of size issues
UPDERA(DA,RECEPT,FOUND) ;Mark ERA as posted to paper EOB
+1 NEW Y,X,DR,DIE,%
+2 DO NOW^%DTC
+3 SET DIE="^RCY(344.4,"
SET FOUND=0
+4 ;Update Receipt #, EFT Match Status, Detail Post Status and Paper EOB
+5 SET DR=".08///"_RECEPT_";.09///2;.14///2;20.03///1"
+6 ;Update Date/Time Posted and User fields
+7 SET DR=DR_";7.01///"_%_";7.02///"_DUZ
+8 DO ^DIE
+9 IF '$DATA(Y)
Begin DoDot:1
+10 KILL DIR
+11 SET DIR(0)="EA"
+12 SET DIR("A",1)="ERA HAS BEEN MARKED AS POSTED USING PAPER EOB"
+13 SET DIR("A")="Press ENTER to continue: "
WRITE !
DO ^DIR
KILL DIR
+14 SET FOUND=1
End DoDot:1
+15 IF '$TEST
WRITE !,"Unable to update ERA for receipt "_RECEPT,!
+16 QUIT FOUND
+17 ;
+18 ; Get Reciept Date (moved from RCDPEM2
RCDATE(RECEPT) ;
+1 NEW RCRECTDA
+2 ;Get receipt IEN
+3 SET RCRECTDA=$ORDER(^RCY(344,"B",RECEPT,0))
if 'RCRECTDA
QUIT 0
+4 ;Return Receipt date
+5 QUIT $PIECE($GET(^RCY(344,RCRECTDA,0)),U,3)
+6 ;
AMT(RECEPT) ;Total Receipt amount
+1 NEW RCRECTDA,RCTRAN,RCTOT
+2 ;Get receipt IEN
+3 SET RCRECTDA=$ORDER(^RCY(344,"B",RECEPT,0))
if 'RCRECTDA
QUIT 0
+4 ;Total the Receipt transactions
+5 SET RCTRAN=0
SET RCTOT=0
+6 FOR
SET RCTRAN=$ORDER(^RCY(344,RCRECTDA,1,RCTRAN))
if 'RCTRAN
QUIT
Begin DoDot:1
+7 SET RCTOT=RCTOT+$PIECE($GET(^RCY(344,RCRECTDA,1,RCTRAN,0)),U,4)
End DoDot:1
+8 QUIT RCTOT
+9 ;
+10 ; Moved from RCDPEM2 for Manual match because RCDPEM2 was too big in size
+11 ; END, DTRNG, RCERA, RCMBG, START variables are newed and cleaned up in RCDPEM2
ML0() ;
ML0A ; Select ERA to use from screen
SET RCERA=$$SEL^RCDPEWL7()
+1 ; Save the line, we need it when we go back to the worklist.
SET RCMBG=VALMBG
+2 IF RCERA=0
QUIT 1
+3 ; Get the zero node for this ERA
SET RCERA(0)=^RCY(344.4,RCERA,0)
+4 ; PRCA*4.5*326
IF ((+($PIECE(RCERA(0),U,9)))>0)!($PIECE(RCERA(0),U,8)'="")
Begin DoDot:1
+5 WRITE !,"ERA is already matched please select another ERA..."
+6 DO WAIT^VALM1
End DoDot:1
QUIT 1
+7 SET DIR("A")="Select EFT by date Range? (Y/N) "
SET DIR(0)="YA"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+8 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT 1
+9 ; Go to the EFT Selection
IF Y<1
GOTO MLQ
+10 ; flag indicating date range selected
SET DTRNG=Y
+11 KILL DIR
SET DIR("?")="Enter the earliest date for the selection range."
+12 ; value in DIR(0) for %DT = APE: ask date, past assumed, echo answer
+13 SET DIR(0)="DAO^:"_DT_":APE"
SET DIR("A")="Start Date: "
DO ^DIR
KILL DIR
+14 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
QUIT 1
+15 SET START=Y
KILL DIR,X,Y
+16 SET DIR("?")="Enter the latest date for the selection range."
+17 SET DIR(0)="DAO^"_START_":"_DT_":APE"
SET DIR("A")="End Date: "
SET DIR("B")=$$FMTE^XLFDT(DT)
+18 DO ^DIR
KILL DIR
+19 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
QUIT 1
+20 SET END=Y
+21 ;
MLQ QUIT 0
