Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCDPRU

RCDPRU.m

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