IBCEMSR2 ;BI/ALB - non-MRA PRODUCTIVITY REPORT ;02/14/11
;;2.0;INTEGRATED BILLING;**447**;21-MAR-94;Build 80
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
EN ; Main Routine Entry Point
N IBQ,IBDIV,IBBDT,IBEDT,IBSUM,IBSCR,IBPAGE,POP
S IBPAGE=0
N IBLTMPH ; Report Header Information
N IBLTMP ; Data Collection Array
W !!,"Report requires 132 Columns"
S IBQ=0 ; quit flag
; Prompts to the user:
D DIV Q:IBQ ; Division(s)
D SUM Q:IBQ ; Summary or Full Report
D DTR Q:IBQ ; From-To date range
D DEVICE Q:IBQ ; Print to device
K ^TMP($J,"IBCEMSR2") ; Clear the temporary accumulator
D RUN Q:IBQ ; Run Report
K ^TMP($J,"IBCEMSR2") ; Clear the temporary accumulator
Q
;
DIV ; Collect Division(s)
N DIC,DIR,DIRUT,X,Y
W ! S DIR("B")="ALL",DIR("A")="Run this report for All divisions or Selected Divisions: "
S DIR(0)="SA^ALL:All divisions;S:Selected divisions" D ^DIR
I $D(DIRUT) S IBQ=1 Q
S IBDIV=Y Q:Y="ALL"
; Collect divisions
F D Q:Y'>0
. W ! S DIC("A")="Division: ",DIC=40.8,DIC(0)="AEQM" D ^DIC
. I $D(DIRUT) S IBQ=1 Q
. I Y'>0 Q
. S IBDIV(+Y)=""
I $O(IBDIV(""))="" S IBQ=1 Q ; None selected
Q
;
DTR ; Get Date Range
N %DT,Y,X,IBIDT ; Local subroutine variables.
S IBBDT=$$FMADD^XLFDT(DT,-7) ; Earliest date set in stack for global routine use.
S IBEDT=DT ; Latest date set in stack for global routine use.
;
; Don't allow the user to go back earlier than patch install date.
S X=$$INSTALDT^XPDUTL("IB*2.0*447",.IBIDT)
I X=0 W !!,"This report can't be run before installing patch IB*2.0*447.",! S IBQ=1 Q
S IBIDT=$P($S(X:$O(IBIDT("")),1:DT),".",1)
I IBBDT<IBIDT S IBBDT=IBIDT
DTR1 ; Return for invalid "Earliest EOB Receipt Date"
S %DT="AEX"
S %DT("A")="Earliest EOB Receipt Date: "
S %DT("B")=$$FMTE^XLFDT(IBBDT)
W ! D ^%DT K %DT
I Y<0 S IBQ=1 Q
I +Y<IBIDT D G DTR1
. W !!,"The Earliest EOB Receipt Date can't be before ",$$FMTE^XLFDT(IBIDT),!
I +Y>DT D G DTR1
. W !!,"Future Dates are not allowed.",!
S IBBDT=+Y
DTR2 ; Return for invalid "Latest EOB Receipt Date"
S %DT="AEX"
S %DT("A")="Latest EOB Receipt Date: "
S %DT("B")=$$FMTE^XLFDT(DT)
D ^%DT K %DT
I Y<0 S IBQ=1 Q
S IBEDT=+Y
I IBEDT<IBBDT D G DTR2
. W !!,"The Latest EOB Receipt Date can't be before ",$$FMTE^XLFDT(IBBDT),!
I +Y>DT D G DTR2
. W !!,"Future Dates are not allowed.",!
W !!
Q
;
SUM ; Ask if printing a Summary or Full report.
N DIR,DIRUT,X,Y
W ! S DIR("B")="Summary",DIR("A")="Print a Summary or a Full report? "
S DIR(0)="SA^S:Summary;F:Full" D ^DIR
I $D(DIRUT) S IBQ=1 Q
S IBSUM=Y
Q
;
DEVICE ; Request Device Information
N %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
K IO("Q")
S %ZIS="QM"
W ! D ^%ZIS
I POP S IBQ=1 Q
S IBSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
I $D(IO("Q")) D S IBQ=1
. S ZTRTN="RUN^IBCEMSR2"
. S ZTIO=ION
. S ZTSAVE("IB*")=""
. S ZTDESC="IB NON-MRA PRODUCTIVITY REPORT"
. D ^%ZTLOAD
. W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
. D HOME^%ZIS
U IO
Q
;
RUN ; Run Report
U IO
D COLLECT ; Collect the data in Local Array "IBLTMP"
D REPORT
I 'IBSCR W !,@IOF
D ^%ZISC
Q
;
COLLECT ; Collect Information, Scan through the EOB Cross Reference
; Input: IBDIV, IBBDT, IBEDT
N IBDT,IBEOB,IBZ,MRAUSR,DIVCNT,IBX
S IBX=0 F DIVCNT=0:1 S IBX=$O(IBDIV(IBX)) Q:'IBX ; Count the requested Divisions
S IBLTMPH("ALLDIV")="DIVISION TOTALS"
I IBDIV="ALL" S IBLTMPH("ALLDIV")="ALL DIVISION TOTALS"
I DIVCNT>1 S IBLTMPH("ALLDIV")="ALL SELECTED DIVISION TOTALS"
;
S IBDT=IBBDT-.000001
; Use new Entry date x-ref: EOBTYP=0 ^IBM(361.1,"AEDT",EOBTYP,ENTRY DT,IEN)=""
F S IBDT=$O(^IBM(361.1,"AEDT",0,IBDT)) Q:'IBDT D
. I IBDT<IBBDT Q
. I (IBDT\1)>IBEDT Q
. S IBEOB=0 F S IBEOB=$O(^IBM(361.1,"AEDT",0,IBDT,IBEOB)) Q:'IBEOB D
.. D COLLECT1
Q
;
COLLECT1 ; Collect Information, Get Data for specific EOB and BILL/CLAIM
N IBIFN,IBFLDS,IBX
N IBOE ; Dict 361.1 EXPLANATION OF BENEFITS field data.
N IBOB ; Dict 399 BILL/CLAIMS field data current claim.
N IBOBS ; Dict 399 BILL/CLAIMS field data Secondary Claim.
N IBOBT ; Dict 399 BILL/CLAIMS field data Tertiary Claim.
; Initial Testing
; Get all the EOB Data
; FIELD .01 POINTER TO BILL/CLAIMS FILE (#399)
; FIELD .13 CLAIM STATUS, 1-PROCESSED, 2-DENIED, 3-PENDED, 4-REVERSAL, 5-OTHER
; FIELD .15 INSURANCE SEQUENCE, 1-PRIMARY, 2-SECONDARY, 3-TERTIARY
; FIELD .16 REVIEW STATUS, 0-NOT REVIEWED, 1-REVIEW IN PROCESS, 1.5-COB PROCESSED, NOT AUTHORIZED,
; 2-ACCEPTED-INTERIM EOB, 3-ACCEPTED-COMPLETE EOB, 4-REJECTED, 9-CLAIM CANCELLED
; FIELD 2.04 TOTAL SUBMITTED CHARGES
D IBOBJ(361.1,IBEOB,".01;.13;.15;.16;2.04",.IBOE) ; Load EOB Data.
;
; Quit if an associated bill number doesn't exist
S IBIFN=IBOE(.01) I IBIFN="" Q
;
; Get all the BILL/CLAIMS Data
; FIELD .13 STATUS, 0-CLOSED, 1-ENTERED/NOT REVIEWED, 2-REQUEST MRA, 3-AUTHORIZED,
; 4-PRNT/TX, 5-**NOT USED**, 7-CANCELLED
; FIELD .19 FORM TYPE, POINTER TO BILL FORM TYPE FILE (#353), 2-CMS1500, 3-UB4
; FIELD .21 CURRENT BILL PAYER SEQUENCE, P-PRIMARY, S-SECONDARY, T-TERTIARY, A-PATIENT
; FIELD .22 DEFAULT DIVISION, POINTER TO MEDICAL CENTER DIVISION FILE (#40.8)
; FIELD .27 BILL CHARGE TYPE, 1-INSTITUTIONAL, 2-PROFESSIONAL
; FIELD 7 MRA REQUESTED DATE
; FIELD 8 MRA REQUESTOR, POINTER TO NEW PERSON FILE (#200)
; FIELD 21 LAST ELECTRONIC EXTRACT DATE
; FIELD 27 FORCE CLAIM TO PRINT
; FIELD 35 AUTO PROCESS, 1-WORKLIST, 2-LOCAL PRINT, 3-EDI, 4-NO LONGER ON WORK LIST
; FIELD 38 REMOVED FROM WORKLIST, RM-REMOVED, PC-PROCESS COB, CL-CLONE, CA-CANCELLED, CR-CORRECTED
; FIELD 125 PRIMARY BILL #
; FIELD 126 SECONDARY BILL #
; FIELD 127 TERTIARY BILL #
; FIELD 201 TOTAL CHARGES
; FIELD 218 PRIMARY PRIOR PAYMENT
; FIELD 219 SECONDARY PRIOR PAYMENT
D IBOBJ(399,IBIFN,".13;.19;.21;.22;.27;7;8;21;27;35;38;125;126;127;201;218;219;302;303",.IBOB) ; Load BILL/CLAIMS Data.
I IBOB(126) D IBOBJ(399,IBOB(126),".13;.19;.21;.22;.27;7;8;21;27;35;38;125;126;127;201;218;219;302;303",.IBOBS) ; Load Secondary BILL/CLAIMS Data.
I IBOB(127) D IBOBJ(399,IBOB(127),".13;.19;.21;.22;.27;7;8;21;27;35;38;125;126;127;201;218;219;302;303",.IBOBT) ; Load Tertiary BILL/CLAIMS Data.
;
; Quit if this bill contains a MRA date.
; I IBOB(7) Q Removed to allow secondary Non-MRA EOBs.
;
; Quit if this Insurance Company WNR for this sequence
I $$WNRBILL^IBEFUNC(IBIFN,IBOE(.15)) Q
;
; Quit if this BILL/CLAIM isn't a 2-CMS-1500 or 3-UB-04
I IBOB(.19)'=2,IBOB(.19)'=3 Q
;
; Quit if this BILL/CLAIM isn't from a selected Division
I IBDIV'="ALL",'$D(IBDIV(+IBOB(.22))) Q
;
D COLLECT2^IBCEMSR3 ; Accumulate information for the Detailed Report
D COLLECT3^IBCEMSR3 ; Accumulate information for the Summary Report
D CALCPCT^IBCEMSR5 ; Calculate the Summary Report Percentages
Q
;
REPORT ; IF REQUESTED DO DETAIL REPORT, ALWAYS DO SUMMARY REPORT
N IBLNUMB,IBLTEXT,IBCLERK,IBDIV2
; Do the Full report if requested.
I IBSUM="F" D
. D HDR
. S IBDIV2="DIVISION"
. W !,"DIVISION: ","*** ",IBLTMPH("ALLDIV")," ***",! D CHKP Q:IBQ
. F IBLNUMB=2:1 S IBLTEXT=$T(FFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END" Q:IBQ D PARSE
. S IBDIV2=0 F S IBDIV2=$O(IBLTMP(IBDIV2)) Q:+IBDIV2=0 Q:IBQ D
.. W !,"DIVISION: ",$$GET1^DIQ(40.8,IBDIV2_",",.01),! D CHKP Q:IBQ
.. F IBLNUMB=2:1 S IBLTEXT=$T(FFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END" Q:IBQ D PARSE
; Do the Summary report if requested.
I IBSUM="S" D
. D HDR
. W !,"SUMMARY",! D CHKP Q:IBQ
. S IBDIV2="DIVISION"
. W "DIVISION: ","*** ",IBLTMPH("ALLDIV")," ***",! D CHKP Q:IBQ
. F IBLNUMB=2:1 S IBLTEXT=$T(SFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END" Q:IBQ D PARSE
. S IBDIV2=0 F S IBDIV2=$O(IBLTMP(IBDIV2)) Q:+IBDIV2=0 Q:IBQ D
.. W !,"DIVISION: ",$$GET1^DIQ(40.8,IBDIV2_",",.01),! D CHKP Q:IBQ
.. F IBLNUMB=2:1 S IBLTEXT=$T(SFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END" Q:IBQ D PARSE
Q
;
HDR ; Report header
N IBI
S IBPAGE=IBPAGE+1
W @IOF,"Non-MRA Productivity Report for period covering "_$$FMTE^XLFDT(IBBDT)_" thru "_$$FMTE^XLFDT(IBEDT)," ",?100,$$FMTE^XLFDT(DT)," Page ",IBPAGE
W ! F IBI=1:1:$S($G(IOM):IOM,1:130) W "-"
W !
Q
;
CHKP ; Check for End Of Page
I $Y>(IOSL-4) D:IBSCR Q:IBQ D HDR
. N X,Y,DTOUT,DUOUT,DIRUT,DIR
. U IO(0) S DIR(0)="E" D ^DIR S:$D(DIRUT) IBQ=2
. U IO
Q
;
PARSE ; USE TEXT INFORMATION FROM FFORM & SFORM TO PRODUCE THE REPORT
N IBACCUM
S IBACCUM=$$TRIM^XLFSTR($P(IBLTEXT,";",4))
S:IBACCUM="" IBACCUM="SKIP"
S IBLTEXT=$P(IBLTEXT,";",5)
W ?($P(IBLTEXT,U,1)),$$TRIM^XLFSTR($P(IBLTEXT,U,2))
W:$$TRIM^XLFSTR($P(IBLTEXT,U,5))="" ?($P(IBLTEXT,U,3)),$J($G(IBLTMP(IBDIV2,IBACCUM,3)),$P(IBLTEXT,U,4))
W:$$TRIM^XLFSTR($P(IBLTEXT,U,5))'="" ?($P(IBLTEXT,U,3)),$J($G(IBLTMP(IBDIV2,IBACCUM,3)),$P(IBLTEXT,U,4),$P(IBLTEXT,U,5))
W ?($P(IBLTEXT,U,6)),$$TRIM^XLFSTR($P(IBLTEXT,U,7))
W:$$TRIM^XLFSTR($P(IBLTEXT,U,10))="" ?($P(IBLTEXT,U,8)),$J($G(IBLTMP(IBDIV2,IBACCUM,2)),$P(IBLTEXT,U,9)),!
W:$$TRIM^XLFSTR($P(IBLTEXT,U,10))'="" ?($P(IBLTEXT,U,8)),$J($G(IBLTMP(IBDIV2,IBACCUM,2)),$P(IBLTEXT,U,9),$P(IBLTEXT,U,10)),!
D CHKP Q:IBQ
Q
;
IBOBJ(IBDICT,IBIEN,IBFLDS,IBARRY) ; LOAD DATA ARRAY
N IBTMPARR,IBX K IBARRY
D GETS^DIQ(IBDICT,IBIEN_",",IBFLDS,"I","IBTMPARR")
S IBX="" F S IBX=$O(IBTMPARR(IBDICT,IBIEN_",",IBX)) Q:IBX="" D
. S IBARRY(IBX)=IBTMPARR(IBDICT,IBIEN_",",IBX,"I")
Q
;
IBDOC ; Print accumulater list to screen
N IBLNUMB,IBLTEXT
W !,"Detail Form Accumulators",!
W "-------------------------",!
F IBLNUMB=2:1 S IBLTEXT=$T(FFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END" D
. W $P(IBLTEXT,";",4),?10,$$TRIM^XLFSTR($P(IBLTEXT,U,2)),!
W !,"Summary Form Accumulators",!
W "-------------------------",!
F IBLNUMB=2:1 S IBLTEXT=$T(SFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END" D
. W $P(IBLTEXT,";",4),?10,$$TRIM^XLFSTR($P(IBLTEXT,U,2)),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMSR2 10268 printed Dec 13, 2024@02:11:05 Page 2
IBCEMSR2 ;BI/ALB - non-MRA PRODUCTIVITY REPORT ;02/14/11
+1 ;;2.0;INTEGRATED BILLING;**447**;21-MAR-94;Build 80
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EN ; Main Routine Entry Point
+1 NEW IBQ,IBDIV,IBBDT,IBEDT,IBSUM,IBSCR,IBPAGE,POP
+2 SET IBPAGE=0
+3 ; Report Header Information
NEW IBLTMPH
+4 ; Data Collection Array
NEW IBLTMP
+5 WRITE !!,"Report requires 132 Columns"
+6 ; quit flag
SET IBQ=0
+7 ; Prompts to the user:
+8 ; Division(s)
DO DIV
if IBQ
QUIT
+9 ; Summary or Full Report
DO SUM
if IBQ
QUIT
+10 ; From-To date range
DO DTR
if IBQ
QUIT
+11 ; Print to device
DO DEVICE
if IBQ
QUIT
+12 ; Clear the temporary accumulator
KILL ^TMP($JOB,"IBCEMSR2")
+13 ; Run Report
DO RUN
if IBQ
QUIT
+14 ; Clear the temporary accumulator
KILL ^TMP($JOB,"IBCEMSR2")
+15 QUIT
+16 ;
DIV ; Collect Division(s)
+1 NEW DIC,DIR,DIRUT,X,Y
+2 WRITE !
SET DIR("B")="ALL"
SET DIR("A")="Run this report for All divisions or Selected Divisions: "
+3 SET DIR(0)="SA^ALL:All divisions;S:Selected divisions"
DO ^DIR
+4 IF $DATA(DIRUT)
SET IBQ=1
QUIT
+5 SET IBDIV=Y
if Y="ALL"
QUIT
+6 ; Collect divisions
+7 FOR
Begin DoDot:1
+8 WRITE !
SET DIC("A")="Division: "
SET DIC=40.8
SET DIC(0)="AEQM"
DO ^DIC
+9 IF $DATA(DIRUT)
SET IBQ=1
QUIT
+10 IF Y'>0
QUIT
+11 SET IBDIV(+Y)=""
End DoDot:1
if Y'>0
QUIT
+12 ; None selected
IF $ORDER(IBDIV(""))=""
SET IBQ=1
QUIT
+13 QUIT
+14 ;
DTR ; Get Date Range
+1 ; Local subroutine variables.
NEW %DT,Y,X,IBIDT
+2 ; Earliest date set in stack for global routine use.
SET IBBDT=$$FMADD^XLFDT(DT,-7)
+3 ; Latest date set in stack for global routine use.
SET IBEDT=DT
+4 ;
+5 ; Don't allow the user to go back earlier than patch install date.
+6 SET X=$$INSTALDT^XPDUTL("IB*2.0*447",.IBIDT)
+7 IF X=0
WRITE !!,"This report can't be run before installing patch IB*2.0*447.",!
SET IBQ=1
QUIT
+8 SET IBIDT=$PIECE($SELECT(X:$ORDER(IBIDT("")),1:DT),".",1)
+9 IF IBBDT<IBIDT
SET IBBDT=IBIDT
DTR1 ; Return for invalid "Earliest EOB Receipt Date"
+1 SET %DT="AEX"
+2 SET %DT("A")="Earliest EOB Receipt Date: "
+3 SET %DT("B")=$$FMTE^XLFDT(IBBDT)
+4 WRITE !
DO ^%DT
KILL %DT
+5 IF Y<0
SET IBQ=1
QUIT
+6 IF +Y<IBIDT
Begin DoDot:1
+7 WRITE !!,"The Earliest EOB Receipt Date can't be before ",$$FMTE^XLFDT(IBIDT),!
End DoDot:1
GOTO DTR1
+8 IF +Y>DT
Begin DoDot:1
+9 WRITE !!,"Future Dates are not allowed.",!
End DoDot:1
GOTO DTR1
+10 SET IBBDT=+Y
DTR2 ; Return for invalid "Latest EOB Receipt Date"
+1 SET %DT="AEX"
+2 SET %DT("A")="Latest EOB Receipt Date: "
+3 SET %DT("B")=$$FMTE^XLFDT(DT)
+4 DO ^%DT
KILL %DT
+5 IF Y<0
SET IBQ=1
QUIT
+6 SET IBEDT=+Y
+7 IF IBEDT<IBBDT
Begin DoDot:1
+8 WRITE !!,"The Latest EOB Receipt Date can't be before ",$$FMTE^XLFDT(IBBDT),!
End DoDot:1
GOTO DTR2
+9 IF +Y>DT
Begin DoDot:1
+10 WRITE !!,"Future Dates are not allowed.",!
End DoDot:1
GOTO DTR2
+11 WRITE !!
+12 QUIT
+13 ;
SUM ; Ask if printing a Summary or Full report.
+1 NEW DIR,DIRUT,X,Y
+2 WRITE !
SET DIR("B")="Summary"
SET DIR("A")="Print a Summary or a Full report? "
+3 SET DIR(0)="SA^S:Summary;F:Full"
DO ^DIR
+4 IF $DATA(DIRUT)
SET IBQ=1
QUIT
+5 SET IBSUM=Y
+6 QUIT
+7 ;
DEVICE ; Request Device Information
+1 NEW %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
+2 KILL IO("Q")
+3 SET %ZIS="QM"
+4 WRITE !
DO ^%ZIS
+5 IF POP
SET IBQ=1
QUIT
+6 SET IBSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET ZTRTN="RUN^IBCEMSR2"
+9 SET ZTIO=ION
+10 SET ZTSAVE("IB*")=""
+11 SET ZTDESC="IB NON-MRA PRODUCTIVITY REPORT"
+12 DO ^%ZTLOAD
+13 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+14 DO HOME^%ZIS
End DoDot:1
SET IBQ=1
+15 USE IO
+16 QUIT
+17 ;
RUN ; Run Report
+1 USE IO
+2 ; Collect the data in Local Array "IBLTMP"
DO COLLECT
+3 DO REPORT
+4 IF 'IBSCR
WRITE !,@IOF
+5 DO ^%ZISC
+6 QUIT
+7 ;
COLLECT ; Collect Information, Scan through the EOB Cross Reference
+1 ; Input: IBDIV, IBBDT, IBEDT
+2 NEW IBDT,IBEOB,IBZ,MRAUSR,DIVCNT,IBX
+3 ; Count the requested Divisions
SET IBX=0
FOR DIVCNT=0:1
SET IBX=$ORDER(IBDIV(IBX))
if 'IBX
QUIT
+4 SET IBLTMPH("ALLDIV")="DIVISION TOTALS"
+5 IF IBDIV="ALL"
SET IBLTMPH("ALLDIV")="ALL DIVISION TOTALS"
+6 IF DIVCNT>1
SET IBLTMPH("ALLDIV")="ALL SELECTED DIVISION TOTALS"
+7 ;
+8 SET IBDT=IBBDT-.000001
+9 ; Use new Entry date x-ref: EOBTYP=0 ^IBM(361.1,"AEDT",EOBTYP,ENTRY DT,IEN)=""
+10 FOR
SET IBDT=$ORDER(^IBM(361.1,"AEDT",0,IBDT))
if 'IBDT
QUIT
Begin DoDot:1
+11 IF IBDT<IBBDT
QUIT
+12 IF (IBDT\1)>IBEDT
QUIT
+13 SET IBEOB=0
FOR
SET IBEOB=$ORDER(^IBM(361.1,"AEDT",0,IBDT,IBEOB))
if 'IBEOB
QUIT
Begin DoDot:2
+14 DO COLLECT1
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
COLLECT1 ; Collect Information, Get Data for specific EOB and BILL/CLAIM
+1 NEW IBIFN,IBFLDS,IBX
+2 ; Dict 361.1 EXPLANATION OF BENEFITS field data.
NEW IBOE
+3 ; Dict 399 BILL/CLAIMS field data current claim.
NEW IBOB
+4 ; Dict 399 BILL/CLAIMS field data Secondary Claim.
NEW IBOBS
+5 ; Dict 399 BILL/CLAIMS field data Tertiary Claim.
NEW IBOBT
+6 ; Initial Testing
+7 ; Get all the EOB Data
+8 ; FIELD .01 POINTER TO BILL/CLAIMS FILE (#399)
+9 ; FIELD .13 CLAIM STATUS, 1-PROCESSED, 2-DENIED, 3-PENDED, 4-REVERSAL, 5-OTHER
+10 ; FIELD .15 INSURANCE SEQUENCE, 1-PRIMARY, 2-SECONDARY, 3-TERTIARY
+11 ; FIELD .16 REVIEW STATUS, 0-NOT REVIEWED, 1-REVIEW IN PROCESS, 1.5-COB PROCESSED, NOT AUTHORIZED,
+12 ; 2-ACCEPTED-INTERIM EOB, 3-ACCEPTED-COMPLETE EOB, 4-REJECTED, 9-CLAIM CANCELLED
+13 ; FIELD 2.04 TOTAL SUBMITTED CHARGES
+14 ; Load EOB Data.
DO IBOBJ(361.1,IBEOB,".01;.13;.15;.16;2.04",.IBOE)
+15 ;
+16 ; Quit if an associated bill number doesn't exist
+17 SET IBIFN=IBOE(.01)
IF IBIFN=""
QUIT
+18 ;
+19 ; Get all the BILL/CLAIMS Data
+20 ; FIELD .13 STATUS, 0-CLOSED, 1-ENTERED/NOT REVIEWED, 2-REQUEST MRA, 3-AUTHORIZED,
+21 ; 4-PRNT/TX, 5-**NOT USED**, 7-CANCELLED
+22 ; FIELD .19 FORM TYPE, POINTER TO BILL FORM TYPE FILE (#353), 2-CMS1500, 3-UB4
+23 ; FIELD .21 CURRENT BILL PAYER SEQUENCE, P-PRIMARY, S-SECONDARY, T-TERTIARY, A-PATIENT
+24 ; FIELD .22 DEFAULT DIVISION, POINTER TO MEDICAL CENTER DIVISION FILE (#40.8)
+25 ; FIELD .27 BILL CHARGE TYPE, 1-INSTITUTIONAL, 2-PROFESSIONAL
+26 ; FIELD 7 MRA REQUESTED DATE
+27 ; FIELD 8 MRA REQUESTOR, POINTER TO NEW PERSON FILE (#200)
+28 ; FIELD 21 LAST ELECTRONIC EXTRACT DATE
+29 ; FIELD 27 FORCE CLAIM TO PRINT
+30 ; FIELD 35 AUTO PROCESS, 1-WORKLIST, 2-LOCAL PRINT, 3-EDI, 4-NO LONGER ON WORK LIST
+31 ; FIELD 38 REMOVED FROM WORKLIST, RM-REMOVED, PC-PROCESS COB, CL-CLONE, CA-CANCELLED, CR-CORRECTED
+32 ; FIELD 125 PRIMARY BILL #
+33 ; FIELD 126 SECONDARY BILL #
+34 ; FIELD 127 TERTIARY BILL #
+35 ; FIELD 201 TOTAL CHARGES
+36 ; FIELD 218 PRIMARY PRIOR PAYMENT
+37 ; FIELD 219 SECONDARY PRIOR PAYMENT
+38 ; Load BILL/CLAIMS Data.
DO IBOBJ(399,IBIFN,".13;.19;.21;.22;.27;7;8;21;27;35;38;125;126;127;201;218;219;302;303",.IBOB)
+39 ; Load Secondary BILL/CLAIMS Data.
IF IBOB(126)
DO IBOBJ(399,IBOB(126),".13;.19;.21;.22;.27;7;8;21;27;35;38;125;126;127;201;218;219;302;303",.IBOBS)
+40 ; Load Tertiary BILL/CLAIMS Data.
IF IBOB(127)
DO IBOBJ(399,IBOB(127),".13;.19;.21;.22;.27;7;8;21;27;35;38;125;126;127;201;218;219;302;303",.IBOBT)
+41 ;
+42 ; Quit if this bill contains a MRA date.
+43 ; I IBOB(7) Q Removed to allow secondary Non-MRA EOBs.
+44 ;
+45 ; Quit if this Insurance Company WNR for this sequence
+46 IF $$WNRBILL^IBEFUNC(IBIFN,IBOE(.15))
QUIT
+47 ;
+48 ; Quit if this BILL/CLAIM isn't a 2-CMS-1500 or 3-UB-04
+49 IF IBOB(.19)'=2
IF IBOB(.19)'=3
QUIT
+50 ;
+51 ; Quit if this BILL/CLAIM isn't from a selected Division
+52 IF IBDIV'="ALL"
IF '$DATA(IBDIV(+IBOB(.22)))
QUIT
+53 ;
+54 ; Accumulate information for the Detailed Report
DO COLLECT2^IBCEMSR3
+55 ; Accumulate information for the Summary Report
DO COLLECT3^IBCEMSR3
+56 ; Calculate the Summary Report Percentages
DO CALCPCT^IBCEMSR5
+57 QUIT
+58 ;
REPORT ; IF REQUESTED DO DETAIL REPORT, ALWAYS DO SUMMARY REPORT
+1 NEW IBLNUMB,IBLTEXT,IBCLERK,IBDIV2
+2 ; Do the Full report if requested.
+3 IF IBSUM="F"
Begin DoDot:1
+4 DO HDR
+5 SET IBDIV2="DIVISION"
+6 WRITE !,"DIVISION: ","*** ",IBLTMPH("ALLDIV")," ***",!
DO CHKP
if IBQ
QUIT
+7 FOR IBLNUMB=2:1
SET IBLTEXT=$TEXT(FFORM+IBLNUMB^IBCEMSR4)
if $PIECE(IBLTEXT,";;",2)="END"
QUIT
if IBQ
QUIT
DO PARSE
+8 SET IBDIV2=0
FOR
SET IBDIV2=$ORDER(IBLTMP(IBDIV2))
if +IBDIV2=0
QUIT
if IBQ
QUIT
Begin DoDot:2
+9 WRITE !,"DIVISION: ",$$GET1^DIQ(40.8,IBDIV2_",",.01),!
DO CHKP
if IBQ
QUIT
+10 FOR IBLNUMB=2:1
SET IBLTEXT=$TEXT(FFORM+IBLNUMB^IBCEMSR4)
if $PIECE(IBLTEXT,";;",2)="END"
QUIT
if IBQ
QUIT
DO PARSE
End DoDot:2
End DoDot:1
+11 ; Do the Summary report if requested.
+12 IF IBSUM="S"
Begin DoDot:1
+13 DO HDR
+14 WRITE !,"SUMMARY",!
DO CHKP
if IBQ
QUIT
+15 SET IBDIV2="DIVISION"
+16 WRITE "DIVISION: ","*** ",IBLTMPH("ALLDIV")," ***",!
DO CHKP
if IBQ
QUIT
+17 FOR IBLNUMB=2:1
SET IBLTEXT=$TEXT(SFORM+IBLNUMB^IBCEMSR4)
if $PIECE(IBLTEXT,";;",2)="END"
QUIT
if IBQ
QUIT
DO PARSE
+18 SET IBDIV2=0
FOR
SET IBDIV2=$ORDER(IBLTMP(IBDIV2))
if +IBDIV2=0
QUIT
if IBQ
QUIT
Begin DoDot:2
+19 WRITE !,"DIVISION: ",$$GET1^DIQ(40.8,IBDIV2_",",.01),!
DO CHKP
if IBQ
QUIT
+20 FOR IBLNUMB=2:1
SET IBLTEXT=$TEXT(SFORM+IBLNUMB^IBCEMSR4)
if $PIECE(IBLTEXT,";;",2)="END"
QUIT
if IBQ
QUIT
DO PARSE
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
HDR ; Report header
+1 NEW IBI
+2 SET IBPAGE=IBPAGE+1
+3 WRITE @IOF,"Non-MRA Productivity Report for period covering "_$$FMTE^XLFDT(IBBDT)_" thru "_$$FMTE^XLFDT(IBEDT)," ",?100,$$FMTE^XLFDT(DT)," Page ",IBPAGE
+4 WRITE !
FOR IBI=1:1:$SELECT($GET(IOM):IOM,1:130)
WRITE "-"
+5 WRITE !
+6 QUIT
+7 ;
CHKP ; Check for End Of Page
+1 IF $Y>(IOSL-4)
if IBSCR
Begin DoDot:1
+2 NEW X,Y,DTOUT,DUOUT,DIRUT,DIR
+3 USE IO(0)
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
SET IBQ=2
+4 USE IO
End DoDot:1
if IBQ
QUIT
DO HDR
+5 QUIT
+6 ;
PARSE ; USE TEXT INFORMATION FROM FFORM & SFORM TO PRODUCE THE REPORT
+1 NEW IBACCUM
+2 SET IBACCUM=$$TRIM^XLFSTR($PIECE(IBLTEXT,";",4))
+3 if IBACCUM=""
SET IBACCUM="SKIP"
+4 SET IBLTEXT=$PIECE(IBLTEXT,";",5)
+5 WRITE ?($PIECE(IBLTEXT,U,1)),$$TRIM^XLFSTR($PIECE(IBLTEXT,U,2))
+6 if $$TRIM^XLFSTR($PIECE(IBLTEXT,U,5))=""
WRITE ?($PIECE(IBLTEXT,U,3)),$JUSTIFY($GET(IBLTMP(IBDIV2,IBACCUM,3)),$PIECE(IBLTEXT,U,4))
+7 if $$TRIM^XLFSTR($PIECE(IBLTEXT,U,5))'=""
WRITE ?($PIECE(IBLTEXT,U,3)),$JUSTIFY($GET(IBLTMP(IBDIV2,IBACCUM,3)),$PIECE(IBLTEXT,U,4),$PIECE(IBLTEXT,U,5))
+8 WRITE ?($PIECE(IBLTEXT,U,6)),$$TRIM^XLFSTR($PIECE(IBLTEXT,U,7))
+9 if $$TRIM^XLFSTR($PIECE(IBLTEXT,U,10))=""
WRITE ?($PIECE(IBLTEXT,U,8)),$JUSTIFY($GET(IBLTMP(IBDIV2,IBACCUM,2)),$PIECE(IBLTEXT,U,9)),!
+10 if $$TRIM^XLFSTR($PIECE(IBLTEXT,U,10))'=""
WRITE ?($PIECE(IBLTEXT,U,8)),$JUSTIFY($GET(IBLTMP(IBDIV2,IBACCUM,2)),$PIECE(IBLTEXT,U,9),$PIECE(IBLTEXT,U,10)),!
+11 DO CHKP
if IBQ
QUIT
+12 QUIT
+13 ;
IBOBJ(IBDICT,IBIEN,IBFLDS,IBARRY) ; LOAD DATA ARRAY
+1 NEW IBTMPARR,IBX
KILL IBARRY
+2 DO GETS^DIQ(IBDICT,IBIEN_",",IBFLDS,"I","IBTMPARR")
+3 SET IBX=""
FOR
SET IBX=$ORDER(IBTMPARR(IBDICT,IBIEN_",",IBX))
if IBX=""
QUIT
Begin DoDot:1
+4 SET IBARRY(IBX)=IBTMPARR(IBDICT,IBIEN_",",IBX,"I")
End DoDot:1
+5 QUIT
+6 ;
IBDOC ; Print accumulater list to screen
+1 NEW IBLNUMB,IBLTEXT
+2 WRITE !,"Detail Form Accumulators",!
+3 WRITE "-------------------------",!
+4 FOR IBLNUMB=2:1
SET IBLTEXT=$TEXT(FFORM+IBLNUMB^IBCEMSR4)
if $PIECE(IBLTEXT,";;",2)="END"
QUIT
Begin DoDot:1
+5 WRITE $PIECE(IBLTEXT,";",4),?10,$$TRIM^XLFSTR($PIECE(IBLTEXT,U,2)),!
End DoDot:1
+6 WRITE !,"Summary Form Accumulators",!
+7 WRITE "-------------------------",!
+8 FOR IBLNUMB=2:1
SET IBLTEXT=$TEXT(SFORM+IBLNUMB^IBCEMSR4)
if $PIECE(IBLTEXT,";;",2)="END"
QUIT
Begin DoDot:1
+9 WRITE $PIECE(IBLTEXT,";",4),?10,$$TRIM^XLFSTR($PIECE(IBLTEXT,U,2)),!
End DoDot:1
+10 QUIT
