RCDPPLB ;ALB/TJB - ERA/PROVIDER LEVEL ADJUSTMENTS REPORT ;1/02/15 10:00am
;;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 - ERA/PROVIDER LEVEL ADJUSTMENTS REPORT
;
; DESCRIPTION : The following generates a report to display ERA data with PLB
; data details. The report is ad-hoc and allow the user to extract report
; data, as well as view and manage refund requests for all PLB adjustment
; codes (FB, WO, 72, IR, J1, L6, CS, WU, etc.):
;
EN ; Entry point for Report
N %ZIS,CD,CRHDR,CZ,DIVHDR,DUOUT,DTOUT,DIR,DTOK,DL,DX0,EXLN,FILE,I,IEN,IDX,IX,JJ,KK,PCT,POP,PY,R,RCCD,RCODE
N RCDET,RCDISP,RCDONE,RCDT1,RCDT2,RCDET,RCDONE,RCEXCEL,RCHR,RCJOB,RCPG,RCTLIST,RCRD,RCNOW,RCPAR,RCLPAY,RCPAYS
N RCQUIT,RCSORT,RCSTOP,RCSTAT,RCTIN,RCTYPE,RCWHICH
N TY,X,XX,XCNT,Y,Z,ZN,ZPPY,ZPY,ZTDESC,ZTRTN,ZTSAVE,ZTSK,ZTSTOP,ZZ,ZZPNAME
S RCQUIT=0,RCODE="" ; Global variable to signal exit
;
; ICR 1077 - Get division/station
D DIVISION^VAUTOMA
I 'VAUTD&($D(VAUTD)'=11) G PLBQ
S DIR("A")="(S)ummary or(D)etail Report format? ",DIR(0)="SA^S:Summary Information only;D:Detail and Totals"
S DIR("B")="SUMMARY" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") G PLBQ
S RCDET=(Y="D")
;
; Get PLB Codes for report
D PLBC(.RCODE) G:$G(RCODE)']"" PLBQ
;
S RCTYPE=$$RTYPE^RCDPEU1() G:RCTYPE=-1 PLBQ ; PRCA*4.5*326 - Add Tricare filter to Med/Pharm/Both
S RCWHICH=$$NMORTIN^RCDPEAPP() Q:RCWHICH=-1 ; PRCA*4.5*326 - Filter by Payer Name or TIN
;
S RCPAR("SELC")=$$PAYRNG^RCDPEU1(0,1,RCWHICH) ; PRCA*4.5*326 - Selected or Range of Payers
G:RCPAR("SELC")=-1 PLBQ ; PRCA*4.5*326 '^' or timeout
S RCPAYS=RCPAR("SELC")
;
I RCPAR("SELC")'="A" D G:XX=-1 PLBQ ; PRCA*4.5*326 - Since we don't want all payers
. S RCPAR("TYPE")=RCTYPE ; prompt for payers we do want
. S RCPAR("SRCH")=$S(RCWHICH=2:"T",1:"N")
. S RCPAR("FILE")=344.4
. S RCPAR("DICA")="Select Insurance Company"_$S(RCWHICH=1:" NAME: ",1:" TIN: ")
. S XX=$$SELPAY^RCDPEU1(.RCPAR)
;
S DIR("A")="Sort Report (C)odes or (P)ayer?: ",DIR(0)="SA^C:PLB Codes;P:Payer Name;CODES:PLB Codes"
S DIR("B")="CODES" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") G PLBQ
S RCSORT=$E(Y,1)
;
S DIR("?")="Enter the Beginning date for the report"
S DIR(0)="DAO^:"_DT_":APE",DIR("A")="Start Date: ",DIR("B")="T" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") G PLBQ
S RCDT1=Y
S DIR("?")="Enter the end date for the report"
S DIR("B")="T"
S DIR(0)="DAO^"_RCDT1_":"_DT_":APE",DIR("A")="End Date: " D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") G PLBQ
S RCDT2=Y
S DTOK=$$CHECKDT^RCDPRU(RCDT1,RCDT2,344.4)
I 'DTOK W !!,"*** Note: Date Range "_$$DATE^RCDPRU(RCDT1)_" - "_$$DATE^RCDPRU(RCDT2)," ***",! W "*** No Records found ***",! D ASK^RCDPRU(.RCQUIT) G PLBQ
; Removed Excel per Susan on 03/24/2015 meeting
; Get input to export to excel.
S RCEXCEL=""
;S RCEXCEL=$$DISPTY^RCDPRU()
;D:RCEXCEL INFO^RCDPRU
;
S %ZIS="QM" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTRTN="ENQ^RCDPPLB",ZTDESC="AR - 835 Provider Adjustment & Payer Data Report"
. S ZTSAVE("*")=""
. S ZTSAVE("^TMP(""RCDPEU1"",$J,")=""
. D ^%ZTLOAD
. W !!,$S($D(ZTSK):"Your task number"_ZTSK_" has been queued.",1:"Unable to queue this job.")
. K ZTSK,IO("Q") D HOME^%ZIS
U IO
;
ENQ ; Start here for queued report
S RCNOW=$$NOW^RCDPRU(),RCPG=0,$P(RCHR,"=",IOM)=""
;
K ^TMP("RCDPPLB_REPORT",$J)
; Collect the data and put it into the ^TMP global
D GETDATA($G(RCODE),RCPAYS,RCTYPE,$G(RCSORT),RCDT1,RCDT2,$NA(^TMP("RCDPPLB_REPORT",$J)),.VAUTD)
;
REPORT ; Print out the report
; Set up Division Header Text and PLB Code Header Text
S RCSL=0
S:VAUTD=1 DIVHDR="ALL" D:VAUTD=0
. N I S DIVHDR="",I="" F S I=$O(VAUTD(I)) Q:I="" S:DIVHDR'="" DIVHDR=DIVHDR_", "_VAUTD(I) S:DIVHDR="" DIVHDR=VAUTD(I)
S CRHDR=RCODE
; Trim information so it will fit on an 80 or IOM character line
D:($L(DIVHDR)+$L(CRHDR))>(IOM-25)
. N VAL,DH,CH,R1,R2 S DH=0,CH=0,R1=0,R2=0,VAL=(IOM-25)\2 ; get half of the screen length
. S:$L(DIVHDR)>VAL DH=1 S:$L(CRHDR)>VAL CH=1 S:DH=0 R1=VAL-$L(DIVHDR) S:CH=0 R2=VAL-$L(CRHDR)
. I $L(DIVHDR)>(VAL+R2) S DIVHDR=$E(DIVHDR,1,(VAL+R2))_"..."
. I $L(CRHDR)>(VAL+R1) S CRHDR=$E(CRHDR,1,(VAL+R2))_"..."
;
I 'RCEXCEL D
. S RCSTOP=$$NEWPG(.RCPG,1,.RCSL,RCSORT) ; PRCA*4.5*326 - use $$NEWPG for first header
E D
. ; Excel Report
. W "CODE^PAYER^TIN^REP_DATE^AMOUNT",!
;
S $P(ZLN,"-",80)="",$P(ZDLN,"=",80)="",$P(ZLN2,"-",78)="",ZLN2=" "_ZLN2,RCSL=7
; Do Grand totals first - per Susan 7/16/2015
S DX0=$G(^TMP("RCDPPLB_REPORT",$J,"TOTALS")),PCT=0
S:+$P(DX0,U,5)'=0 PCT=$J(($P(DX0,U,1)/$P(DX0,U,5))*100,3,0)
S:+$P(DX0,U,5)=0 PCT="ERR"
I RCSL>=(IOSL-4) S RCQUIT=$$NEWPG(.RCPG,1,.RCSL,RCSORT) Q:RCQUIT
W ! S RCSL=RCSL+1
W "GRAND TOTALS FOR ALL PLB CODES & PAYERS ON REPORT",! S RCSL=RCSL+1
W " TOTAL #ERAs: ",$J($P(DX0,U,3),6,0)," ADJ: ",PCT,"% [TOT AMT ADJUSTED / TOT AMT BILLED]",! S RCSL=RCSL+1
W " AMT ADJUST: $",$J($P(DX0,U,1),11,2)," AMT BILLED: $",$J($P(DX0,U,5),11,2)," AMT PAID: $",$J($P(DX0,U,2),11,2),! S RCSL=RCSL+1
W !,ZDLN,!! S RCSL=RCSL+1
I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) G:RCQUIT PLBQ
;
S ZZ="" F S ZZ=$O(^TMP("RCDPPLB_REPORT",$J,"SUMMARY",ZZ)) Q:ZZ="" S ZDAT=^TMP("RCDPPLB_REPORT",$J,"SUMMARY",ZZ) D Q:RCQUIT
. D:RCSORT="C" Q:RCQUIT
.. W "ADJ CODE: ",ZZ," # ERAs: ",$J($P(ZDAT,U,3),5)," ADJ: ",$S(+$P(ZDAT,U,5)>0:$J((($P(ZDAT,U,1)/$P(ZDAT,U,5))*100),3,0),1:"ERR"),"% [TOT AMT ADJUSTED / TOT AMT BILLED]",! S RCSL=RCSL+1
.. I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
.. W " AMT ADJUST: ",$J($P(ZDAT,U,1),8,2)," AMT BILLED: ",$J($P(ZDAT,U,5),9,2)," AMT PAID: ",$J($P(ZDAT,U,2),9,2),! S RCSL=RCSL+1
.. I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
.. W "ADJ CODE TEXT: ",$P(ZDAT,U,4),! S RCSL=RCSL+1
.. I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
.. W ZLN,! S RCSL=RCSL+1
.. I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
.. S PY="",CZ=0 F S PY=$O(^TMP("RCDPPLB_REPORT",$J,"SUMMARY",ZZ,PY)) Q:PY="" S ZPY=^TMP("RCDPPLB_REPORT",$J,"SUMMARY",ZZ,PY) D Q:RCQUIT S CZ=CZ+1
... S:+($P(ZPY,U,5))'=0 ZPPY=$J((($P(ZPY,U,1)/$P(ZPY,U,5))*100),3,0)
... S:+($P(ZPY,U,5))=0 ZPPY="ERR"
... I CZ>0 W ZLN2,! S RCSL=RCSL+1
... W " PAYER NAME/TIN",!
... S RCSL=RCSL+1
... W " ",$$PAYTIN^RCDPRU2(PY,76),! ; PRCA*4.5*321
... S RCSL=RCSL+1 ; PRCA*4.5*321
... I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
... W " #ERAs: ",$J($P(ZPY,U,3),4)," ADJ: ",ZPPY,"% [ADJ: ",$J($P(ZPY,U,1),8,2),"/ BILLED: ",$J($P(ZPY,U,5),9,2),"] PAID: ",$J($P(ZPY,U,2),9,2),! S RCSL=RCSL+1
... D:RCDET DETAIL(RCSORT,ZZ,PY,$NA(^TMP("RCDPPLB_REPORT",$J))) Q:RCQUIT
.. W:'RCQUIT ZLN,! S RCSL=RCSL+1
. D:RCSORT="P" Q:RCQUIT
.. W " PAYER NAME/TIN",!
.. S RCSL=RCSL+1
.. W " ",$$PAYTIN^RCDPRU2(ZZ,76),! ; PRCA*4.5*321
.. S RCSL=RCSL+1 ; PRCA*4.5*321
.. ; PRCA*4.5*321 End modified code block
.. I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
.. W "# ERAs:",$J($P(ZDAT,U,3),5)," ADJ: ",$S(+$P(ZDAT,U,5)>0:$J((($P(ZDAT,U,1)/$P(ZDAT,U,5))*100),3,0),1:"ERR"),"% [AMT ADJ:",$J($P(ZDAT,U,1),8,2),"/ BILLED:",$J($P(ZDAT,U,5),9,2),"] PAID:",$J($P(ZDAT,U,2),9,2),! S RCSL=RCSL+1
.. I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
.. W ZLN,! S RCSL=RCSL+1
.. I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
.. S PY="",CZ=0 F S PY=$O(^TMP("RCDPPLB_REPORT",$J,"SUMMARY",ZZ,PY)) Q:PY="" S ZPY=^TMP("RCDPPLB_REPORT",$J,"SUMMARY",ZZ,PY) D Q:RCQUIT S CZ=CZ+1
... S ZPPY=$S(+$P(ZPY,U,5)'=0:$J((($P(ZPY,U,1)/$P(ZPY,U,5))*100),3,0),1:"ERR")
... I CZ>0 W ZLN2,! S RCSL=RCSL+1
... W " ADJ CODE: ",PY," ADJ CODE TXT: ",$P(ZPY,U,4),! S RCSL=RCSL+1
... I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
... W " #ERAs: ",$J($P(ZPY,U,3),4)," ADJ: ",ZPPY,"% [ADJ: ",$J($P(ZPY,U,1),8,2),"/ BILLED: ",$J($P(ZPY,U,5),9,2),"] PAID: ",$J($P(ZPY,U,2),9,2),! S RCSL=RCSL+1
... D:RCDET DETAIL(RCSORT,ZZ,PY,$NA(^TMP("RCDPPLB_REPORT",$J))) Q:RCQUIT
.. I 'RCQUIT W ZLN,! S RCSL=RCSL+1
D:'RCQUIT ASK^RCDPRU(.RCQUIT)
PLBQ ;
K RCQUIT,VAUTD,ZDAT,ZLN,ZDLN,ZLN2
K ^TMP("RCDPPLB_REPORT",$J),^TMP("RCDPEU1",$J) ; PRCA*4.5*326
Q
;
; SORT = by CODES or Payer; CAT = CODE or Payer/TIN to lookup
; DET = Second subscipt either Payer/TIN if Sort="C" or PLB Code if Sort="P"; ZGBL = Global to use through indirection
DETAIL(SORT,CAT,DET,ZGBL) ; Detail Report
N ZLN1,ZFS,ZZ,ZDET,ZDZN,ZPCT,ZADJ,ZBIL,ZPD S $P(ZLN1,"-",77)="-",ZLN1=" "_ZLN1
S ZFS=$S(SORT="C":"ERA",1:"PAYR")
W ZLN1,! S RCSL=RCSL+1
I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
W " #ERA DATE %ADJ ADJUST BILLED PAID CHECK#",! S RCSL=RCSL+1
I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
W " TRACE#",! S RCSL=RCSL+1
I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
;W " COMMENTS ",! S RCSL=RCSL+1
W " REFERENCE#",! S RCSL=RCSL+1
I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
S ZZ="" F S ZZ=$O(@ZGBL@(ZFS,CAT,ZZ)) Q:ZZ="" S ZDZN=@ZGBL@(ZFS,CAT,ZZ,0) D Q:RCQUIT
. S ZDET=$$GETDT(SORT,CAT,DET,ZDZN,ZGBL)
. Q:ZDET'=DET ; If this isn't the same then skip
. S ZADJ=$$DAMT("A",$S(SORT="C":CAT,1:DET),$P(ZDZN,U,1),ZFS,ZGBL),ZBIL=$$DAMT("B",CAT,$P(ZDZN,U,1),ZFS,ZGBL),ZPD=$$DAMT("P",CAT,$P(ZDZN,U,1),ZFS,ZGBL)
. S ZPCT=$S(ZBIL'=0:$J(((ZADJ/ZBIL)*100),3,0),1:"ERR")
. W $J($P(ZDZN,U,1),9),?12,$$DATE^RCDPRU($P(ZDZN,U,4)),?23,$J(ZPCT,3,0),?29,$J(ZADJ,9,2),?42,$J(ZBIL,9,2),?54,$J(ZPD,9,2),?68,$P(ZDZN,U,13),! S RCSL=RCSL+1
. I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
. W ?9,$P(ZDZN,U,2),! S RCSL=RCSL+1 ; Trace
. I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
. W ?9,$$DTCM(CAT,$P(ZDZN,U,1),ZFS,ZGBL),! S RCSL=RCSL+1 ; Reference #
Q:RCQUIT
I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT) Q:RCQUIT
;W ZLN1,! S RCSL=RCSL+1
Q
;
GETDT(SORT,CAT,DT,ZND,ZGBL) ; Get detail information for this entry
N MYDT,MM
S MYDT=""
I SORT="C" Q $P(ZND,U,6)_"/"_$P(ZND,U,3)
; Otherwise we have a payer sort and need to do more work
S MM=0.11 F S MM=$O(@ZGBL@("00_ERA",$P(ZND,U,1),MM)) Q:MM="" I $P(@ZGBL@("00_ERA",$P(ZND,U,1),MM),U,1)=DT S MYDT=$P(@ZGBL@("00_ERA",$P(ZND,U,1),MM),U,1) Q
Q MYDT
;
; Get the type of amount from the ^TMP global
DAMT(TYPE,FIRST,ZIEN,XFS,XGBL) ; Get amounts
N ZAMT,XDN S ZAMT=0
; Adjustment amount
I TYPE="A" D Q ZAMT
. S AA=0.1 F S AA=$O(@XGBL@("00_ERA",ZIEN,AA)) Q:AA="" D
.. Q:$P(@XGBL@("00_ERA",ZIEN,AA),U,1)'=FIRST ; Not the correct record
.. ; Otherwise we have the right record get the adjustment amount
.. S ZAMT=ZAMT+$P(@XGBL@("00_ERA",ZIEN,AA),U,2)
; Total billed on ERA
I TYPE="B" Q @XGBL@("00_ERA",ZIEN,0.1)
; Paid Amount
I TYPE="P" Q $P(@XGBL@("00_ERA",ZIEN,0),U,5)
Q ZAMT
;
DTCM(FIRST,ZIEN,XFS,XGBL) ; Get comment or reference number
N AA,XDN,ZCM
S XDN=0,ZCM=""
D
. S AA=0.1 F S AA=$O(@XGBL@("00_ERA",ZIEN,AA)) Q:AA=""!(XDN=1) D
.. Q:$P(@XGBL@("00_ERA",ZIEN,AA),U,1)'=FIRST ; Not the correct record
.. ; Otherwise we have the right record get the adjustment amount
.. S ZCM=$P(@XGBL@("00_ERA",ZIEN,AA),U,3),XDN=1
Q ZCM
;
HDR(CD) ; Report header
Q:CD "EDI LOCKBOX 835 PROVIDER LEVEL ADJUSTMENT (PLB) REPORT - DETAIL"
Q "EDI LOCKBOX 835 PROVIDER LEVEL ADJUSTMENT (PLB) REPORT - SUMMARY"
;
HDRP(Z,X,Z1) ; Print Header (Z=String, X=1 (line feed) X=0 (no LF), Z1 (page number right justified)
N LGT S LGT=$L(Z)+$L($G(Z1))
I $G(X)=1 W !
W ?(IOM-LGT\2),Z W:$G(Z1)]"" ?(IOM-$L(Z1)),Z1
Q
;
NEWPG(RCPG,RCNEW,RCSL,CD) ; Check for new page needed, output header
; RCPG = Page number passwd by referece
; RCNEW = 1 to force new page
; RCSL = page length passed by reference
; Function returns 1 if user chooses to stop output
N ZSTOP S ZSTOP=0
I RCNEW!'RCPG!(($Y+5)>IOSL) D
. D:RCPG ASK^RCDPRU(.ZSTOP) Q:ZSTOP
. S RCPG=RCPG+1 W @IOF
. D HDRP($$HDR(RCDET),1,"Page: "_RCPG)
. D HDRP("SORT by "_$S($E(CD,1)="C":"PLB CODES",1:"PAYER NAMES")_" REPORT RUN DATE: "_RCNOW,1)
. D HDRP("DIVISION: "_DIVHDR_" Codes: "_CRHDR,1)
. ; PRCA*4.5*326 - Include M/P/T filter in header
. S XX="835 PAYERS: "_$S(RCWHICH=2:"None",1:$S($E(RCPAYS)="A":"All",1:"Selected"))_" "
. S XX=XX_"835 PAYER TINs: "_$S(RCWHICH=1:"None",1:$S($E(RCPAYS)="A":"All",1:"Selected"))_" "
. S XX=XX_"MEDICAL/PHARMACY/TRICARE: "
. S XX=XX_$S(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARMACY",RCTYPE="T":"TRICARE",1:"ALL")
. D HDRP(XX,1)
. D HDRP("Date Range: "_$$DATE^RCDPRU(RCDT1)_" - "_$$DATE^RCDPRU(RCDT2),1)
. W !,RCHR,! S RCSL=7
Q ZSTOP
;
; Get data for report and apply filters if necessary
GETDATA(GPLB,RCPAYS,RCTYPE,GSORT,GSTART,GSTOP,GARRAY,GDIV) ;
N SDT,IEN,CD,CNT,IX,ZX,XY,RM,PARR,PNARR,PTARR,RCSET,GLINE,ZN,ZED,ZEN,ZPAY,ZTIN,ZDESC,ZZ,RCERR,RCGX,RCEB,EOBTOT,STA,STNUM,STNAM,ZLVL
S SDT=$O(^RCY(344.4,"AC",GSTART),-1)
S ZLVL=$S(GSORT="C":"ERA",1:"PAYR")
; Set up arrays for filtering on PLB, PAYER name and Payer TINs
D RNG^RCDPRU("PLB",.GPLB,.PARR)
; RNG^RCDPRU("PAYER",GPAYER,.PARR),RNG^RCDPRU("TIN",GTIN,.PARR)
;Get possible ERAs to work on from ^RCY(344.4,"AC") index
F S SDT=$O(^RCY(344.4,"AC",SDT)) Q:SDT=""!(SDT>GSTOP) D
. S IEN="" F S IEN=$O(^RCY(344.4,"AC",SDT,IEN)) Q:IEN="" S ZN=^RCY(344.4,IEN,0) D
.. I GDIV=0 D ERASTA^RCDPEM4(IEN,.STA,.STNUM,.STNAM) Q:'$D(GDIV(STA)) ; If not the right Division/station then get next ERA
.. K RCGX D GETS^DIQ(344.4,IEN_",","2*;","E","RCGX") Q:$D(RCGX)=0 ; Quit if no PLBs on this ERA
.. S ZTIN=$$GET1^DIQ(344.4,IEN_",",.03,"E"),ZPAY=$$GET1^DIQ(344.4,IEN_",",.06,"E")
.. ;
.. I RCPAYS="A",RCTYPE'="A" D Q:'ZZ ; PRCA*4.5*326 If all payers included, check by type
... S ZZ=$$ISTYPE^RCDPEU1(344.4,IEN,RCTYPE)
.. ; Check Payer Name
.. I RCPAYS'="A" D Q:'ZZ ; PRCA*4.5*326
... S ZZ=$$ISSEL^RCDPEU1(344.4,IEN)
.. ;
.. ; Billed amount on the EOBs, Get EOB Details
.. K RCEB D GETS^DIQ(344.4,IEN_",","1*;","I","RCEB")
.. ; Walk EOB Details and get the total amount billed
.. S EOBTOT=0
.. I $D(RCEB)>9 S XY="" F S XY=$O(RCEB(344.41,XY)) Q:XY="" S EOBTOT=EOBTOT+$$GET1^DIQ(361.1,RCEB(344.41,XY,.02,"I")_",","2.04","E")
.. ; Get list of PLB Codes for this ERA
.. S IX="" K CD F ZZ=1:1 S IX=$O(RCGX(344.42,IX)) Q:IX="" D
... I '$$CHECK("PLB",RCGX(344.42,IX,.02,"E"),.PARR) Q ; If plb not included in report quit and go to the next entry
... ; Get IEN for PLB Code, then get description for code from file 345.1
... S ZEN=$$FIND1^DIC(345.1,"","",RCGX(344.42,IX,.02,"E"),"B","","RCERR") S:$G(ZEN)]"" ZDESC=$$GET1^DIQ(345.1,ZEN_",",.05,"","RCERR")
... S:$G(ZDESC)="" ZDESC=$G(RCGX(344.42,IX,.04,"E")) ; If no description use the Description from FSC
... S:$G(ZDESC)="" ZDESC="Bad data recieved from FSC" ; Otherwise make one up.
... ; PLB Code ^ Adj. Amount ^ Reference / Comment ^ Code Description
... S CD(ZZ)=$S(RCGX(344.42,IX,.02,"E")'="":RCGX(344.42,IX,.02,"E"),1:"00")_U_RCGX(344.42,IX,.03,"E")_U_RCGX(344.42,IX,.01,"E")_U_ZDESC
... S @GARRAY@("00_ERA",IEN,ZZ)=CD(ZZ)
... ; Add items to report global sorted by Payer or PLB Code
... S @GARRAY@("00_ERA",IEN,0)=ZN,@GARRAY@("00_ERA",IEN,0.1)=EOBTOT
... ;D:GSORT="C" BYCODE^RCDPRU(ZN,.CD,IEN,GARRAY,EOBTOT) D:GSORT="P" BYPAYR^RCDPRU(ZN,.CD,IEN,GARRAY,EOBTOT)
... S ZED=$S(GSORT="C":$P(CD(ZZ),U,1),1:$P(ZN,U,6)_"/"_$P(ZN,U,3)),@GARRAY@(ZLVL,ZED,IEN,0)=ZN
D SUMIT^RCDPRU(GARRAY,ZLVL,GSORT)
Q
; Check to see if this ITEM is included for processing
CHECK(TYPE,ITEM,ARRAY) ;
; If all are included no need to check further
I TYPE="TIN" S:$E(ITEM,$L(ITEM))'=" " ITEM=ITEM_" " ; Add space to TIN if needed.
Q:$G(ARRAY(TYPE))="ALL" 1
Q:$G(ARRAY(TYPE,ITEM))=1 1
Q 0
;
PLBC(RET) ; Get PLB Codes to limit for report or all
N PLLIST,PLCODE,DTOUT,DUOUT,FILE S FILE=345.1
S DIR("A")="Select (C)ode, (R)ange of Codes or (A)ll ?: ",DIR(0)="SA^A:All Codes;C:Single Code;R:Range/List of Codes"
S DIR("B")="ALL" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") S RCQUIT=1 Q
S PLLIST=Y
I PLLIST="A" S RET="ALL" Q
I PLLIST="C" D Q
.; if invalid code return here
C1 .;
. S DIR("A")="Enter a Code: ",DIR(0)="FA^1:200"
. S DIR("?")="Only a single codes can be entered as: WO"
. S DIR("?",1)="Please enter one Code for the report."
. S DIR("?",2)="The single validated code will be included in the report."
. D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT)!(Y="") S RCQUIT=1 Q
. S PLCODE=$$UP^RCDPRU(X),PLCODE=$TR(PLCODE," ","")
. I (PLCODE[":"),(PLCODE["-"),(PLCODE[",") W !!,"PLB Code: "_PLCODE_" not found, Please try again...",! S X="",PLCODE="" G C1
. I '$$VAL(FILE,.PLCODE) W !!,"PLB Code: "_PLCODE_" not found, Please try again...",! S X="",PLCODE="" G C1
. S RET=PLCODE
;
I PLLIST="R" D
. ; if invalid range/list of codes return here
C2 . ;
. S DIR("A")="Enter a List or Range of Codes",DIR(0)="F^1:200"
. S DIR("?")="Codes can be entered as: WO,51,AH:CT"
. S DIR("?",1)="Please enter a list or range of Codes, use a comma between elements"
. S DIR("?",2)="and a colon ':' or '-' to delimit ranges of codes."
. D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT)!(Y="") S RCQUIT=1 Q
. S PLCODE=$$UP^RCDPRU(X) I '$$VAL(FILE,.PLCODE) W !!,"PLB Code: "_PLCODE_" not found, Please try again...",! S X="",PLCODE="" G C2
. S RET=PLCODE
Q
;
VAL(XF,CODE) ; Validate a range or list of PLB Codes
; If invalid code is found VAILD = 0 and CODE will contain the offending codes
Q $$VAL^RCDPRU(XF,.CODE)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPPLB 17903 printed Oct 16, 2024@17:47:01 Page 2
RCDPPLB ;ALB/TJB - ERA/PROVIDER LEVEL ADJUSTMENTS REPORT ;1/02/15 10:00am
+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 - ERA/PROVIDER LEVEL ADJUSTMENTS REPORT
+5 ;
+6 ; DESCRIPTION : The following generates a report to display ERA data with PLB
+7 ; data details. The report is ad-hoc and allow the user to extract report
+8 ; data, as well as view and manage refund requests for all PLB adjustment
+9 ; codes (FB, WO, 72, IR, J1, L6, CS, WU, etc.):
+10 ;
EN ; Entry point for Report
+1 NEW %ZIS,CD,CRHDR,CZ,DIVHDR,DUOUT,DTOUT,DIR,DTOK,DL,DX0,EXLN,FILE,I,IEN,IDX,IX,JJ,KK,PCT,POP,PY,R,RCCD,RCODE
+2 NEW RCDET,RCDISP,RCDONE,RCDT1,RCDT2,RCDET,RCDONE,RCEXCEL,RCHR,RCJOB,RCPG,RCTLIST,RCRD,RCNOW,RCPAR,RCLPAY,RCPAYS
+3 NEW RCQUIT,RCSORT,RCSTOP,RCSTAT,RCTIN,RCTYPE,RCWHICH
+4 NEW TY,X,XX,XCNT,Y,Z,ZN,ZPPY,ZPY,ZTDESC,ZTRTN,ZTSAVE,ZTSK,ZTSTOP,ZZ,ZZPNAME
+5 ; Global variable to signal exit
SET RCQUIT=0
SET RCODE=""
+6 ;
+7 ; ICR 1077 - Get division/station
+8 DO DIVISION^VAUTOMA
+9 IF 'VAUTD&($DATA(VAUTD)'=11)
GOTO PLBQ
+10 SET DIR("A")="(S)ummary or(D)etail Report format? "
SET DIR(0)="SA^S:Summary Information only;D:Detail and Totals"
+11 SET DIR("B")="SUMMARY"
DO ^DIR
KILL DIR
+12 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
GOTO PLBQ
+13 SET RCDET=(Y="D")
+14 ;
+15 ; Get PLB Codes for report
+16 DO PLBC(.RCODE)
if $GET(RCODE)']""
GOTO PLBQ
+17 ;
+18 ; PRCA*4.5*326 - Add Tricare filter to Med/Pharm/Both
SET RCTYPE=$$RTYPE^RCDPEU1()
if RCTYPE=-1
GOTO PLBQ
+19 ; PRCA*4.5*326 - Filter by Payer Name or TIN
SET RCWHICH=$$NMORTIN^RCDPEAPP()
if RCWHICH=-1
QUIT
+20 ;
+21 ; PRCA*4.5*326 - Selected or Range of Payers
SET RCPAR("SELC")=$$PAYRNG^RCDPEU1(0,1,RCWHICH)
+22 ; PRCA*4.5*326 '^' or timeout
if RCPAR("SELC")=-1
GOTO PLBQ
+23 SET RCPAYS=RCPAR("SELC")
+24 ;
+25 ; PRCA*4.5*326 - Since we don't want all payers
IF RCPAR("SELC")'="A"
Begin DoDot:1
+26 ; prompt for payers we do want
SET RCPAR("TYPE")=RCTYPE
+27 SET RCPAR("SRCH")=$SELECT(RCWHICH=2:"T",1:"N")
+28 SET RCPAR("FILE")=344.4
+29 SET RCPAR("DICA")="Select Insurance Company"_$SELECT(RCWHICH=1:" NAME: ",1:" TIN: ")
+30 SET XX=$$SELPAY^RCDPEU1(.RCPAR)
End DoDot:1
if XX=-1
GOTO PLBQ
+31 ;
+32 SET DIR("A")="Sort Report (C)odes or (P)ayer?: "
SET DIR(0)="SA^C:PLB Codes;P:Payer Name;CODES:PLB Codes"
+33 SET DIR("B")="CODES"
DO ^DIR
KILL DIR
+34 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
GOTO PLBQ
+35 SET RCSORT=$EXTRACT(Y,1)
+36 ;
+37 SET DIR("?")="Enter the Beginning date for the report"
+38 SET DIR(0)="DAO^:"_DT_":APE"
SET DIR("A")="Start Date: "
SET DIR("B")="T"
DO ^DIR
KILL DIR
+39 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
GOTO PLBQ
+40 SET RCDT1=Y
+41 SET DIR("?")="Enter the end date for the report"
+42 SET DIR("B")="T"
+43 SET DIR(0)="DAO^"_RCDT1_":"_DT_":APE"
SET DIR("A")="End Date: "
DO ^DIR
KILL DIR
+44 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
GOTO PLBQ
+45 SET RCDT2=Y
+46 SET DTOK=$$CHECKDT^RCDPRU(RCDT1,RCDT2,344.4)
+47 IF 'DTOK
WRITE !!,"*** Note: Date Range "_$$DATE^RCDPRU(RCDT1)_" - "_$$DATE^RCDPRU(RCDT2)," ***",!
WRITE "*** No Records found ***",!
DO ASK^RCDPRU(.RCQUIT)
GOTO PLBQ
+48 ; Removed Excel per Susan on 03/24/2015 meeting
+49 ; Get input to export to excel.
+50 SET RCEXCEL=""
+51 ;S RCEXCEL=$$DISPTY^RCDPRU()
+52 ;D:RCEXCEL INFO^RCDPRU
+53 ;
+54 SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+55 IF $DATA(IO("Q"))
Begin DoDot:1
+56 SET ZTRTN="ENQ^RCDPPLB"
SET ZTDESC="AR - 835 Provider Adjustment & Payer Data Report"
+57 SET ZTSAVE("*")=""
+58 SET ZTSAVE("^TMP(""RCDPEU1"",$J,")=""
+59 DO ^%ZTLOAD
+60 WRITE !!,$SELECT($DATA(ZTSK):"Your task number"_ZTSK_" has been queued.",1:"Unable to queue this job.")
+61 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
QUIT
+62 USE IO
+63 ;
ENQ ; Start here for queued report
+1 SET RCNOW=$$NOW^RCDPRU()
SET RCPG=0
SET $PIECE(RCHR,"=",IOM)=""
+2 ;
+3 KILL ^TMP("RCDPPLB_REPORT",$JOB)
+4 ; Collect the data and put it into the ^TMP global
+5 DO GETDATA($GET(RCODE),RCPAYS,RCTYPE,$GET(RCSORT),RCDT1,RCDT2,$NAME(^TMP("RCDPPLB_REPORT",$JOB)),.VAUTD)
+6 ;
REPORT ; Print out the report
+1 ; Set up Division Header Text and PLB Code Header Text
+2 SET RCSL=0
+3 if VAUTD=1
SET DIVHDR="ALL"
if VAUTD=0
Begin DoDot:1
+4 NEW I
SET DIVHDR=""
SET I=""
FOR
SET I=$ORDER(VAUTD(I))
if I=""
QUIT
if DIVHDR'=""
SET DIVHDR=DIVHDR_", "_VAUTD(I)
if DIVHDR=""
SET DIVHDR=VAUTD(I)
End DoDot:1
+5 SET CRHDR=RCODE
+6 ; Trim information so it will fit on an 80 or IOM character line
+7 if ($LENGTH(DIVHDR)+$LENGTH(CRHDR))>(IOM-25)
Begin DoDot:1
+8 ; get half of the screen length
NEW VAL,DH,CH,R1,R2
SET DH=0
SET CH=0
SET R1=0
SET R2=0
SET VAL=(IOM-25)\2
+9 if $LENGTH(DIVHDR)>VAL
SET DH=1
if $LENGTH(CRHDR)>VAL
SET CH=1
if DH=0
SET R1=VAL-$LENGTH(DIVHDR)
if CH=0
SET R2=VAL-$LENGTH(CRHDR)
+10 IF $LENGTH(DIVHDR)>(VAL+R2)
SET DIVHDR=$EXTRACT(DIVHDR,1,(VAL+R2))_"..."
+11 IF $LENGTH(CRHDR)>(VAL+R1)
SET CRHDR=$EXTRACT(CRHDR,1,(VAL+R2))_"..."
End DoDot:1
+12 ;
+13 IF 'RCEXCEL
Begin DoDot:1
+14 ; PRCA*4.5*326 - use $$NEWPG for first header
SET RCSTOP=$$NEWPG(.RCPG,1,.RCSL,RCSORT)
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 ; Excel Report
+17 WRITE "CODE^PAYER^TIN^REP_DATE^AMOUNT",!
End DoDot:1
+18 ;
+19 SET $PIECE(ZLN,"-",80)=""
SET $PIECE(ZDLN,"=",80)=""
SET $PIECE(ZLN2,"-",78)=""
SET ZLN2=" "_ZLN2
SET RCSL=7
+20 ; Do Grand totals first - per Susan 7/16/2015
+21 SET DX0=$GET(^TMP("RCDPPLB_REPORT",$JOB,"TOTALS"))
SET PCT=0
+22 if +$PIECE(DX0,U,5)'=0
SET PCT=$JUSTIFY(($PIECE(DX0,U,1)/$PIECE(DX0,U,5))*100,3,0)
+23 if +$PIECE(DX0,U,5)=0
SET PCT="ERR"
+24 IF RCSL>=(IOSL-4)
SET RCQUIT=$$NEWPG(.RCPG,1,.RCSL,RCSORT)
if RCQUIT
QUIT
+25 WRITE !
SET RCSL=RCSL+1
+26 WRITE "GRAND TOTALS FOR ALL PLB CODES & PAYERS ON REPORT",!
SET RCSL=RCSL+1
+27 WRITE " TOTAL #ERAs: ",$JUSTIFY($PIECE(DX0,U,3),6,0)," ADJ: ",PCT,"% [TOT AMT ADJUSTED / TOT AMT BILLED]",!
SET RCSL=RCSL+1
+28 WRITE " AMT ADJUST: $",$JUSTIFY($PIECE(DX0,U,1),11,2)," AMT BILLED: $",$JUSTIFY($PIECE(DX0,U,5),11,2)," AMT PAID: $",$JUSTIFY($PIECE(DX0,U,2),11,2),!
SET RCSL=RCSL+1
+29 WRITE !,ZDLN,!!
SET RCSL=RCSL+1
+30 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
GOTO PLBQ
+31 ;
+32 SET ZZ=""
FOR
SET ZZ=$ORDER(^TMP("RCDPPLB_REPORT",$JOB,"SUMMARY",ZZ))
if ZZ=""
QUIT
SET ZDAT=^TMP("RCDPPLB_REPORT",$JOB,"SUMMARY",ZZ)
Begin DoDot:1
+33 if RCSORT="C"
Begin DoDot:2
+34 WRITE "ADJ CODE: ",ZZ," # ERAs: ",$JUSTIFY($PIECE(ZDAT,U,3),5)," ADJ: ",$SELECT(+$PIECE(ZDAT,U,5)>0:$JUSTIFY((($PIECE(ZDAT,U,1)/$PIECE(ZDAT,U,5))*100),3,0),1:"ERR"),"% [TOT AMT ADJUSTED / TOT AMT BILLED]",!
SET RCSL=RCSL+1
+35 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+36 WRITE " AMT ADJUST: ",$JUSTIFY($PIECE(ZDAT,U,1),8,2)," AMT BILLED: ",$JUSTIFY($PIECE(ZDAT,U,5),9,2)," AMT PAID: ",$JUSTIFY($PIECE(ZDAT,U,2),9,2),!
SET RCSL=RCSL+1
+37 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+38 WRITE "ADJ CODE TEXT: ",$PIECE(ZDAT,U,4),!
SET RCSL=RCSL+1
+39 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+40 WRITE ZLN,!
SET RCSL=RCSL+1
+41 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+42 SET PY=""
SET CZ=0
FOR
SET PY=$ORDER(^TMP("RCDPPLB_REPORT",$JOB,"SUMMARY",ZZ,PY))
if PY=""
QUIT
SET ZPY=^TMP("RCDPPLB_REPORT",$JOB,"SUMMARY",ZZ,PY)
Begin DoDot:3
+43 if +($PIECE(ZPY,U,5))'=0
SET ZPPY=$JUSTIFY((($PIECE(ZPY,U,1)/$PIECE(ZPY,U,5))*100),3,0)
+44 if +($PIECE(ZPY,U,5))=0
SET ZPPY="ERR"
+45 IF CZ>0
WRITE ZLN2,!
SET RCSL=RCSL+1
+46 WRITE " PAYER NAME/TIN",!
+47 SET RCSL=RCSL+1
+48 ; PRCA*4.5*321
WRITE " ",$$PAYTIN^RCDPRU2(PY,76),!
+49 ; PRCA*4.5*321
SET RCSL=RCSL+1
+50 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+51 WRITE " #ERAs: ",$JUSTIFY($PIECE(ZPY,U,3),4)," ADJ: ",ZPPY,"% [ADJ: ",$JUSTIFY($PIECE(ZPY,U,1),8,2),"/ BILLED: ",$JUSTIFY($PIECE(ZPY,U,5),9,2),"] PAID: ",$JUSTIFY($PIECE(ZPY,U,2),9,2),!
SET RCSL=RCSL+1
+52 if RCDET
DO DETAIL(RCSORT,ZZ,PY,$NAME(^TMP("RCDPPLB_REPORT",$JOB)))
if RCQUIT
QUIT
End DoDot:3
if RCQUIT
QUIT
SET CZ=CZ+1
+53 if 'RCQUIT
WRITE ZLN,!
SET RCSL=RCSL+1
End DoDot:2
if RCQUIT
QUIT
+54 if RCSORT="P"
Begin DoDot:2
+55 WRITE " PAYER NAME/TIN",!
+56 SET RCSL=RCSL+1
+57 ; PRCA*4.5*321
WRITE " ",$$PAYTIN^RCDPRU2(ZZ,76),!
+58 ; PRCA*4.5*321
SET RCSL=RCSL+1
+59 ; PRCA*4.5*321 End modified code block
+60 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+61 WRITE "# ERAs:",$JUSTIFY($PIECE(ZDAT,U,3),5)," ADJ: ",$SELECT(+$PIECE(ZDAT,U,5)>0:$JUSTIFY((($PIECE(ZDAT,U,1)/$PIECE(ZDAT,U,5))*100),3,0),1:"ERR"),"% [AMT ADJ:",$JUSTIFY(...
... $PIECE(ZDAT,U,1),8,2),"/ BILLED:",$JUSTIFY($PIECE(ZDAT,U,5),9,2),"] PAID:",$JUSTIFY($PIECE(ZDAT,U,2),9,2),!
SET RCSL=RCSL+1
+62 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+63 WRITE ZLN,!
SET RCSL=RCSL+1
+64 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+65 SET PY=""
SET CZ=0
FOR
SET PY=$ORDER(^TMP("RCDPPLB_REPORT",$JOB,"SUMMARY",ZZ,PY))
if PY=""
QUIT
SET ZPY=^TMP("RCDPPLB_REPORT",$JOB,"SUMMARY",ZZ,PY)
Begin DoDot:3
+66 SET ZPPY=$SELECT(+$PIECE(ZPY,U,5)'=0:$JUSTIFY((($PIECE(ZPY,U,1)/$PIECE(ZPY,U,5))*100),3,0),1:"ERR")
+67 IF CZ>0
WRITE ZLN2,!
SET RCSL=RCSL+1
+68 WRITE " ADJ CODE: ",PY," ADJ CODE TXT: ",$PIECE(ZPY,U,4),!
SET RCSL=RCSL+1
+69 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+70 WRITE " #ERAs: ",$JUSTIFY($PIECE(ZPY,U,3),4)," ADJ: ",ZPPY,"% [ADJ: ",$JUSTIFY($PIECE(ZPY,U,1),8,2),"/ BILLED: ",$JUSTIFY($PIECE(ZPY,U,5),9,2),"] PAID: ",$JUSTIFY($PIECE(ZPY,U,2),9,2),!
SET RCSL=RCSL+1
+71 if RCDET
DO DETAIL(RCSORT,ZZ,PY,$NAME(^TMP("RCDPPLB_REPORT",$JOB)))
if RCQUIT
QUIT
End DoDot:3
if RCQUIT
QUIT
SET CZ=CZ+1
+72 IF 'RCQUIT
WRITE ZLN,!
SET RCSL=RCSL+1
End DoDot:2
if RCQUIT
QUIT
End DoDot:1
if RCQUIT
QUIT
+73 if 'RCQUIT
DO ASK^RCDPRU(.RCQUIT)
PLBQ ;
+1 KILL RCQUIT,VAUTD,ZDAT,ZLN,ZDLN,ZLN2
+2 ; PRCA*4.5*326
KILL ^TMP("RCDPPLB_REPORT",$JOB),^TMP("RCDPEU1",$JOB)
+3 QUIT
+4 ;
+5 ; SORT = by CODES or Payer; CAT = CODE or Payer/TIN to lookup
+6 ; DET = Second subscipt either Payer/TIN if Sort="C" or PLB Code if Sort="P"; ZGBL = Global to use through indirection
DETAIL(SORT,CAT,DET,ZGBL) ; Detail Report
+1 NEW ZLN1,ZFS,ZZ,ZDET,ZDZN,ZPCT,ZADJ,ZBIL,ZPD
SET $PIECE(ZLN1,"-",77)="-"
SET ZLN1=" "_ZLN1
+2 SET ZFS=$SELECT(SORT="C":"ERA",1:"PAYR")
+3 WRITE ZLN1,!
SET RCSL=RCSL+1
+4 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+5 WRITE " #ERA DATE %ADJ ADJUST BILLED PAID CHECK#",!
SET RCSL=RCSL+1
+6 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+7 WRITE " TRACE#",!
SET RCSL=RCSL+1
+8 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+9 ;W " COMMENTS ",! S RCSL=RCSL+1
+10 WRITE " REFERENCE#",!
SET RCSL=RCSL+1
+11 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+12 SET ZZ=""
FOR
SET ZZ=$ORDER(@ZGBL@(ZFS,CAT,ZZ))
if ZZ=""
QUIT
SET ZDZN=@ZGBL@(ZFS,CAT,ZZ,0)
Begin DoDot:1
+13 SET ZDET=$$GETDT(SORT,CAT,DET,ZDZN,ZGBL)
+14 ; If this isn't the same then skip
if ZDET'=DET
QUIT
+15 SET ZADJ=$$DAMT("A",$SELECT(SORT="C":CAT,1:DET),$PIECE(ZDZN,U,1),ZFS,ZGBL)
SET ZBIL=$$DAMT("B",CAT,$PIECE(ZDZN,U,1),ZFS,ZGBL)
SET ZPD=$$DAMT("P",CAT,$PIECE(ZDZN,U,1),ZFS,ZGBL)
+16 SET ZPCT=$SELECT(ZBIL'=0:$JUSTIFY(((ZADJ/ZBIL)*100),3,0),1:"ERR")
+17 WRITE $JUSTIFY($PIECE(ZDZN,U,1),9),?12,$$DATE^RCDPRU($PIECE(ZDZN,U,4)),?23,$JUSTIFY(ZPCT,3,0),?29,$JUSTIFY(ZADJ,9,2),?42,$JUSTIFY(ZBIL,9,2),?54,$JUSTIFY(ZPD,9,2),?68,$PIECE(ZDZN,U,13),!
SET RCSL=RCSL+1
+18 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+19 ; Trace
WRITE ?9,$PIECE(ZDZN,U,2),!
SET RCSL=RCSL+1
+20 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+21 ; Reference #
WRITE ?9,$$DTCM(CAT,$PIECE(ZDZN,U,1),ZFS,ZGBL),!
SET RCSL=RCSL+1
End DoDot:1
if RCQUIT
QUIT
+22 if RCQUIT
QUIT
+23 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL,RCSORT)
if RCQUIT
QUIT
+24 ;W ZLN1,! S RCSL=RCSL+1
+25 QUIT
+26 ;
GETDT(SORT,CAT,DT,ZND,ZGBL) ; Get detail information for this entry
+1 NEW MYDT,MM
+2 SET MYDT=""
+3 IF SORT="C"
QUIT $PIECE(ZND,U,6)_"/"_$PIECE(ZND,U,3)
+4 ; Otherwise we have a payer sort and need to do more work
+5 SET MM=0.11
FOR
SET MM=$ORDER(@ZGBL@("00_ERA",$PIECE(ZND,U,1),MM))
if MM=""
QUIT
IF $PIECE(@ZGBL@("00_ERA",$PIECE(ZND,U,1),MM),U,1)=DT
SET MYDT=$PIECE(@ZGBL@("00_ERA",$PIECE(ZND,U,1),MM),U,1)
QUIT
+6 QUIT MYDT
+7 ;
+8 ; Get the type of amount from the ^TMP global
DAMT(TYPE,FIRST,ZIEN,XFS,XGBL) ; Get amounts
+1 NEW ZAMT,XDN
SET ZAMT=0
+2 ; Adjustment amount
+3 IF TYPE="A"
Begin DoDot:1
+4 SET AA=0.1
FOR
SET AA=$ORDER(@XGBL@("00_ERA",ZIEN,AA))
if AA=""
QUIT
Begin DoDot:2
+5 ; Not the correct record
if $PIECE(@XGBL@("00_ERA",ZIEN,AA),U,1)'=FIRST
QUIT
+6 ; Otherwise we have the right record get the adjustment amount
+7 SET ZAMT=ZAMT+$PIECE(@XGBL@("00_ERA",ZIEN,AA),U,2)
End DoDot:2
End DoDot:1
QUIT ZAMT
+8 ; Total billed on ERA
+9 IF TYPE="B"
QUIT @XGBL@("00_ERA",ZIEN,0.1)
+10 ; Paid Amount
+11 IF TYPE="P"
QUIT $PIECE(@XGBL@("00_ERA",ZIEN,0),U,5)
+12 QUIT ZAMT
+13 ;
DTCM(FIRST,ZIEN,XFS,XGBL) ; Get comment or reference number
+1 NEW AA,XDN,ZCM
+2 SET XDN=0
SET ZCM=""
+3 Begin DoDot:1
+4 SET AA=0.1
FOR
SET AA=$ORDER(@XGBL@("00_ERA",ZIEN,AA))
if AA=""!(XDN=1)
QUIT
Begin DoDot:2
+5 ; Not the correct record
if $PIECE(@XGBL@("00_ERA",ZIEN,AA),U,1)'=FIRST
QUIT
+6 ; Otherwise we have the right record get the adjustment amount
+7 SET ZCM=$PIECE(@XGBL@("00_ERA",ZIEN,AA),U,3)
SET XDN=1
End DoDot:2
End DoDot:1
+8 QUIT ZCM
+9 ;
HDR(CD) ; Report header
+1 if CD
QUIT "EDI LOCKBOX 835 PROVIDER LEVEL ADJUSTMENT (PLB) REPORT - DETAIL"
+2 QUIT "EDI LOCKBOX 835 PROVIDER LEVEL ADJUSTMENT (PLB) REPORT - SUMMARY"
+3 ;
HDRP(Z,X,Z1) ; Print Header (Z=String, X=1 (line feed) X=0 (no LF), Z1 (page number right justified)
+1 NEW LGT
SET LGT=$LENGTH(Z)+$LENGTH($GET(Z1))
+2 IF $GET(X)=1
WRITE !
+3 WRITE ?(IOM-LGT\2),Z
if $GET(Z1)]""
WRITE ?(IOM-$LENGTH(Z1)),Z1
+4 QUIT
+5 ;
NEWPG(RCPG,RCNEW,RCSL,CD) ; Check for new page needed, output header
+1 ; RCPG = Page number passwd by referece
+2 ; RCNEW = 1 to force new page
+3 ; RCSL = page length passed by reference
+4 ; Function returns 1 if user chooses to stop output
+5 NEW ZSTOP
SET ZSTOP=0
+6 IF RCNEW!'RCPG!(($Y+5)>IOSL)
Begin DoDot:1
+7 if RCPG
DO ASK^RCDPRU(.ZSTOP)
if ZSTOP
QUIT
+8 SET RCPG=RCPG+1
WRITE @IOF
+9 DO HDRP($$HDR(RCDET),1,"Page: "_RCPG)
+10 DO HDRP("SORT by "_$SELECT($EXTRACT(CD,1)="C":"PLB CODES",1:"PAYER NAMES")_" REPORT RUN DATE: "_RCNOW,1)
+11 DO HDRP("DIVISION: "_DIVHDR_" Codes: "_CRHDR,1)
+12 ; PRCA*4.5*326 - Include M/P/T filter in header
+13 SET XX="835 PAYERS: "_$SELECT(RCWHICH=2:"None",1:$SELECT($EXTRACT(RCPAYS)="A":"All",1:"Selected"))_" "
+14 SET XX=XX_"835 PAYER TINs: "_$SELECT(RCWHICH=1:"None",1:$SELECT($EXTRACT(RCPAYS)="A":"All",1:"Selected"))_" "
+15 SET XX=XX_"MEDICAL/PHARMACY/TRICARE: "
+16 SET XX=XX_$SELECT(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARMACY",RCTYPE="T":"TRICARE",1:"ALL")
+17 DO HDRP(XX,1)
+18 DO HDRP("Date Range: "_$$DATE^RCDPRU(RCDT1)_" - "_$$DATE^RCDPRU(RCDT2),1)
+19 WRITE !,RCHR,!
SET RCSL=7
End DoDot:1
+20 QUIT ZSTOP
+21 ;
+22 ; Get data for report and apply filters if necessary
GETDATA(GPLB,RCPAYS,RCTYPE,GSORT,GSTART,GSTOP,GARRAY,GDIV) ;
+1 NEW SDT,IEN,CD,CNT,IX,ZX,XY,RM,PARR,PNARR,PTARR,RCSET,GLINE,ZN,ZED,ZEN,ZPAY,ZTIN,ZDESC,ZZ,RCERR,RCGX,RCEB,EOBTOT,STA,STNUM,STNAM,ZLVL
+2 SET SDT=$ORDER(^RCY(344.4,"AC",GSTART),-1)
+3 SET ZLVL=$SELECT(GSORT="C":"ERA",1:"PAYR")
+4 ; Set up arrays for filtering on PLB, PAYER name and Payer TINs
+5 DO RNG^RCDPRU("PLB",.GPLB,.PARR)
+6 ; RNG^RCDPRU("PAYER",GPAYER,.PARR),RNG^RCDPRU("TIN",GTIN,.PARR)
+7 ;Get possible ERAs to work on from ^RCY(344.4,"AC") index
+8 FOR
SET SDT=$ORDER(^RCY(344.4,"AC",SDT))
if SDT=""!(SDT>GSTOP)
QUIT
Begin DoDot:1
+9 SET IEN=""
FOR
SET IEN=$ORDER(^RCY(344.4,"AC",SDT,IEN))
if IEN=""
QUIT
SET ZN=^RCY(344.4,IEN,0)
Begin DoDot:2
+10 ; If not the right Division/station then get next ERA
IF GDIV=0
DO ERASTA^RCDPEM4(IEN,.STA,.STNUM,.STNAM)
if '$DATA(GDIV(STA))
QUIT
+11 ; Quit if no PLBs on this ERA
KILL RCGX
DO GETS^DIQ(344.4,IEN_",","2*;","E","RCGX")
if $DATA(RCGX)=0
QUIT
+12 SET ZTIN=$$GET1^DIQ(344.4,IEN_",",.03,"E")
SET ZPAY=$$GET1^DIQ(344.4,IEN_",",.06,"E")
+13 ;
+14 ; PRCA*4.5*326 If all payers included, check by type
IF RCPAYS="A"
IF RCTYPE'="A"
Begin DoDot:3
+15 SET ZZ=$$ISTYPE^RCDPEU1(344.4,IEN,RCTYPE)
End DoDot:3
if 'ZZ
QUIT
+16 ; Check Payer Name
+17 ; PRCA*4.5*326
IF RCPAYS'="A"
Begin DoDot:3
+18 SET ZZ=$$ISSEL^RCDPEU1(344.4,IEN)
End DoDot:3
if 'ZZ
QUIT
+19 ;
+20 ; Billed amount on the EOBs, Get EOB Details
+21 KILL RCEB
DO GETS^DIQ(344.4,IEN_",","1*;","I","RCEB")
+22 ; Walk EOB Details and get the total amount billed
+23 SET EOBTOT=0
+24 IF $DATA(RCEB)>9
SET XY=""
FOR
SET XY=$ORDER(RCEB(344.41,XY))
if XY=""
QUIT
SET EOBTOT=EOBTOT+$$GET1^DIQ(361.1,RCEB(344.41,XY,.02,"I")_",","2.04","E")
+25 ; Get list of PLB Codes for this ERA
+26 SET IX=""
KILL CD
FOR ZZ=1:1
SET IX=$ORDER(RCGX(344.42,IX))
if IX=""
QUIT
Begin DoDot:3
+27 ; If plb not included in report quit and go to the next entry
IF '$$CHECK("PLB",RCGX(344.42,IX,.02,"E"),.PARR)
QUIT
+28 ; Get IEN for PLB Code, then get description for code from file 345.1
+29 SET ZEN=$$FIND1^DIC(345.1,"","",RCGX(344.42,IX,.02,"E"),"B","","RCERR")
if $GET(ZEN)]""
SET ZDESC=$$GET1^DIQ(345.1,ZEN_",",.05,"","RCERR")
+30 ; If no description use the Description from FSC
if $GET(ZDESC)=""
SET ZDESC=$GET(RCGX(344.42,IX,.04,"E"))
+31 ; Otherwise make one up.
if $GET(ZDESC)=""
SET ZDESC="Bad data recieved from FSC"
+32 ; PLB Code ^ Adj. Amount ^ Reference / Comment ^ Code Description
+33 SET CD(ZZ)=$SELECT(RCGX(344.42,IX,.02,"E")'="":RCGX(344.42,IX,.02,"E"),1:"00")_U_RCGX(344.42,IX,.03,"E")_U_RCGX(344.42,IX,.01,"E")_U_ZDESC
+34 SET @GARRAY@("00_ERA",IEN,ZZ)=CD(ZZ)
+35 ; Add items to report global sorted by Payer or PLB Code
+36 SET @GARRAY@("00_ERA",IEN,0)=ZN
SET @GARRAY@("00_ERA",IEN,0.1)=EOBTOT
+37 ;D:GSORT="C" BYCODE^RCDPRU(ZN,.CD,IEN,GARRAY,EOBTOT) D:GSORT="P" BYPAYR^RCDPRU(ZN,.CD,IEN,GARRAY,EOBTOT)
+38 SET ZED=$SELECT(GSORT="C":$PIECE(CD(ZZ),U,1),1:$PIECE(ZN,U,6)_"/"_$PIECE(ZN,U,3))
SET @GARRAY@(ZLVL,ZED,IEN,0)=ZN
End DoDot:3
End DoDot:2
End DoDot:1
+39 DO SUMIT^RCDPRU(GARRAY,ZLVL,GSORT)
+40 QUIT
+41 ; Check to see if this ITEM is included for processing
CHECK(TYPE,ITEM,ARRAY) ;
+1 ; If all are included no need to check further
+2 ; Add space to TIN if needed.
IF TYPE="TIN"
if $EXTRACT(ITEM,$LENGTH(ITEM))'=" "
SET ITEM=ITEM_" "
+3 if $GET(ARRAY(TYPE))="ALL"
QUIT 1
+4 if $GET(ARRAY(TYPE,ITEM))=1
QUIT 1
+5 QUIT 0
+6 ;
PLBC(RET) ; Get PLB Codes to limit for report or all
+1 NEW PLLIST,PLCODE,DTOUT,DUOUT,FILE
SET FILE=345.1
+2 SET DIR("A")="Select (C)ode, (R)ange of Codes or (A)ll ?: "
SET DIR(0)="SA^A:All Codes;C:Single Code;R:Range/List of Codes"
+3 SET DIR("B")="ALL"
DO ^DIR
KILL DIR
+4 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RCQUIT=1
QUIT
+5 SET PLLIST=Y
+6 IF PLLIST="A"
SET RET="ALL"
QUIT
+7 IF PLLIST="C"
Begin DoDot:1
+8 ; if invalid code return here
C1 ;
+1 SET DIR("A")="Enter a Code: "
SET DIR(0)="FA^1:200"
+2 SET DIR("?")="Only a single codes can be entered as: WO"
+3 SET DIR("?",1)="Please enter one Code for the report."
+4 SET DIR("?",2)="The single validated code will be included in the report."
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RCQUIT=1
QUIT
+7 SET PLCODE=$$UP^RCDPRU(X)
SET PLCODE=$TRANSLATE(PLCODE," ","")
+8 IF (PLCODE[":")
IF (PLCODE["-")
IF (PLCODE[",")
WRITE !!,"PLB Code: "_PLCODE_" not found, Please try again...",!
SET X=""
SET PLCODE=""
GOTO C1
+9 IF '$$VAL(FILE,.PLCODE)
WRITE !!,"PLB Code: "_PLCODE_" not found, Please try again...",!
SET X=""
SET PLCODE=""
GOTO C1
+10 SET RET=PLCODE
End DoDot:1
QUIT
+11 ;
+12 IF PLLIST="R"
Begin DoDot:1
+13 ; if invalid range/list of codes return here
C2 ;
+1 SET DIR("A")="Enter a List or Range of Codes"
SET DIR(0)="F^1:200"
+2 SET DIR("?")="Codes can be entered as: WO,51,AH:CT"
+3 SET DIR("?",1)="Please enter a list or range of Codes, use a comma between elements"
+4 SET DIR("?",2)="and a colon ':' or '-' to delimit ranges of codes."
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RCQUIT=1
QUIT
+7 SET PLCODE=$$UP^RCDPRU(X)
IF '$$VAL(FILE,.PLCODE)
WRITE !!,"PLB Code: "_PLCODE_" not found, Please try again...",!
SET X=""
SET PLCODE=""
GOTO C2
+8 SET RET=PLCODE
End DoDot:1
+9 QUIT
+10 ;
VAL(XF,CODE) ; Validate a range or list of PLB Codes
+1 ; If invalid code is found VAILD = 0 and CODE will contain the offending codes
+2 QUIT $$VAL^RCDPRU(XF,.CODE)
+3 ;
