- 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 Jan 18, 2025@02:47:40 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