RCDPEAPS ;ALB/DMB - ERA STATUS CHANGE AUDIT REPORT ;Nov 25, 2015
;;4.5;Accounts Receivable;**304,326**;Mar 20, 1995;Build 26
;Per VA Directive 6402, this routine should not be modified.
;
;
EN ;
; Prompt for report type
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,RCALL,RCTYPE,RCERA,RCRANGE ; PRCA*4.5*326
S DIR(0)="SA^S:SINGLE ERA;A:ALL"
S DIR("A")="SELECT (S)ingle ERA or (A)LL: ",DIR("B")="ALL"
D ^DIR
I Y'="S",Y'="A" Q
S RCALL=Y ; PRCA*4.5*326
;
; If Single ERA, select the ERA
S RCERA="",RCTYPE="A"
I RCALL="S" S RCERA=$$SELERA() Q:'RCERA G RANGE ; PRCA*4.5*326
;
; If ALL ERAs, select Type of Payers to include and Date Range for Report
S RCTYPE=$$RTYPE^RCDPEU1("A") I RCTYPE=-1 Q ; PRCA*4.5*326
;
RANGE ; Select date range for audit transactions
S RCRANGE=""
S RCRANGE=$$DTRNG() I 'RCRANGE Q
;
; Prompt for device
N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
S %ZIS="QM"
D ^%ZIS
I POP G ENQ
I $D(IO("Q")) D G ENQ
. S ZTRTN="RUN^RCDPEAPS(RCERA,RCRANGE)"
. S ZTIO=ION
. S ZTSAVE("*")=""
. S ZTDESC="ERA STATUS CHANGE AUDIT REPORT"
. D ^%ZTLOAD
. W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
. D HOME^%ZIS
U IO
;
D RUN(RCERA,RCRANGE)
;
ENQ ;
Q
;
RUN(RCERA,RCRANGE) ;
;
K ^TMP("RCDPEAPS",$J)
;
; Compile Data
D COMPILE(RCERA,RCRANGE)
;
; Generate Report
D REPORT(RCRANGE)
;
K ^TMP("RCDPEAPS",$J)
Q
;
COMPILE(RCERA,RCRANGE) ;
; Compile the data
;
N CNT,BDATE,EDATE,AUDDATE,IEN,CNT,DATA
S CNT=0,BDATE=$P(RCRANGE,U,1)-.000001,EDATE=$P(RCRANGE,U,2)+.999999
;
; If RCERA is non-zero, then we are doing a single ERA
I RCERA D Q
. S IEN="" F S IEN=$O(^RCY(344.72,"E",RCERA,IEN)) Q:'IEN D
.. S DATA=$G(^RCY(344.72,IEN,0))
.. S AUDDATE=$P(DATA,U,1)
.. I AUDDATE="" Q
.. I AUDDATE<BDATE!(AUDDATE>EDATE) Q
.. S CNT=CNT+1
.. S ^TMP("RCDPEAPS",$J,RCERA,AUDDATE,CNT)=$P(DATA,U,4)_U_$P(DATA,U,5)_U_$P(DATA,U,2)_U_$P(DATA,U,6)
;
; If RCERA is zero, then we are gathering data by date
I 'RCERA D Q
. S AUDDATE=BDATE F S AUDDATE=$O(^RCY(344.72,"B",AUDDATE)) Q:'AUDDATE!(AUDDATE>EDATE) D
.. S IEN="" F S IEN=$O(^RCY(344.72,"B",AUDDATE,IEN)) Q:'IEN D
... S DATA=$G(^RCY(344.72,IEN,0))
... I $P(DATA,U,3)="" Q
... S CNT=CNT+1
... S ^TMP("RCDPEAPS",$J,$P(DATA,U,3),AUDDATE,CNT)=$P(DATA,U,4)_U_$P(DATA,U,5)_U_$P(DATA,U,2)_U_$P(DATA,U,6)
Q
;
REPORT(RCRANGE) ;
; Display output
;
; Initialize Report Date, Page Number and Sting of underscores
N RCSCR,RCNOW,RCPG,RCHR,ERA,DATE,CNT,DATA,LINES
S RCSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
S RCNOW=$$UP^XLFSTR($$NOW^RCDPRU()),RCPG=0,RCHR="",$P(RCHR,"-",IOM+1)=""
;
U IO
D HEADER(RCNOW,.RCPG,RCHR,RCRANGE)
I '$D(^TMP("RCDPEAPS",$J)) W !,"No data found"
;
; Display the detail
S ERA="" F S ERA=$O(^TMP("RCDPEAPS",$J,ERA)) Q:'ERA D I RCPG=0 Q
. I RCTYPE'="A",'$$ISTYPE^RCDPEU1(344.4,ERA,RCTYPE) Q ; PRCA*4.5*326 Filter by Medical, Tricare or Pharmacy
. S DATE="" F S DATE=$O(^TMP("RCDPEAPS",$J,ERA,DATE)) Q:'DATE D I RCPG=0 Q
.. S CNT=0 F S CNT=$O(^TMP("RCDPEAPS",$J,ERA,DATE,CNT)) Q:'CNT D I RCPG=0 Q
... S DATA=^TMP("RCDPEAPS",$J,ERA,DATE,CNT)
... S LINES=2
... I $P(DATA,U,4)]"" S LINES=3
... I RCSCR S LINES=LINES+1
... D CHKP(RCNOW,.RCPG,RCHR,RCRANGE,RCSCR,LINES) I RCPG=0 Q
... W !,ERA,?15,$$FMTE^XLFDT(DATE,"2Z"),?38,$$STATUS($P(DATA,U,1)),?49,$$STATUS($P(DATA,U,2))
... W ?63,$E($$GET1^DIQ(200,+$P(DATA,U,3)_",",.01),1,IOM-63)
... I $P(DATA,U,4)]"" W !,?3,$E($P(DATA,U,4),1,IOM-4)
... W !
;
I 'RCSCR W !,@IOF
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
;
I RCPG,RCSCR D PAUSE
Q
;
; Print Header
;
N LINE
W @IOF
S RCPG=RCPG+1
S LINE="EDI Lockbox ERA Status Change Audit Report"
W ?(IOM-$L(LINE)\2),LINE
S LINE="Page: "_RCPG_" "
W ?(IOM-$L(LINE)),LINE
S LINE="RUN DATE: "_RCNOW
S LINE=LINE_" MEDICAL/PHARMACY/TRICARE: "
S LINE=LINE_$S(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARAMCY",RCTYPE="T":"TRICARE",1:"ALL")
W !?(IOM-$L(LINE)\2),LINE
S LINE="DATE RANGE: "_$$FMTE^XLFDT($P(RCRANGE,U,1),"5DZ")_" - "_$$FMTE^XLFDT($P(RCRANGE,U,2),"5DZ")
W !?(IOM-$L(LINE)\2),LINE
;
W !!,"ERA#",?15,"Date/Time Edited",?38,"Status (Old/New)",?63,"User"
W !?3,"Reason Text"
W !,RCHR
Q
;
PAUSE() ;
N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT
S DIR(0)="E"
D ^DIR
Q Y
;
CHKP(RCNOW,RCPG,RCHR,RCRANGE,RCSCR,LINES) ;
; Check if we need to do a page break
;
I $Y'>(IOSL-LINES) Q
I RCSCR,'$$PAUSE S RCPG=0 Q
D HEADER(RCNOW,.RCPG,RCHR,RCRANGE)
Q
;
SELERA() ;
; Lookup on the Electronic Remittance Advice (#344.4) file
;
N DIC,X,Y,DTOUT,DUOUT
S DIC="^RCY(344.4,",DIC(0)="QEAMn"
D ^DIC
I $G(DTOUT)!$G(DUOUT)!(Y=-1) Q 0
Q +Y
;
DTRNG() ;
; Get the date range for the report
;
N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,BDATE
S DIR("?")="ENTER THE EARLIEST AUDIT DATE TO INCLUDE ON THE REPORT"
S DIR(0)="DA^:"_DT_":APE",DIR("A")="START DATE: ",DIR("B")="T" D ^DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") S BDATE=-1 Q 0
S BDATE=Y
K DIR
S DIR("?")="ENTER THE LATEST AUDIT DATE TO INCLUDE ON THE REPORT"
S DIR("B")=Y(0)
S DIR(0)="DA^"_BDATE_":"_DT_":APE",DIR("A")="END DATE: ",DIR("B")="T" D ^DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") Q 0
Q BDATE_"^"_Y
;
STATUS(STATUS) ;
; Convert internal status to external status
I '$D(STATUS) Q ""
I STATUS="" Q "NULL"
Q $$EXTERNAL^DILFD(344.4,4.02,,STATUS)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEAPS 5465 printed Apr 09, 2024@20:44:40 Page 2
RCDPEAPS ;ALB/DMB - ERA STATUS CHANGE AUDIT REPORT ;Nov 25, 2015
+1 ;;4.5;Accounts Receivable;**304,326**;Mar 20, 1995;Build 26
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
EN ;
+1 ; Prompt for report type
+2 ; PRCA*4.5*326
NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,RCALL,RCTYPE,RCERA,RCRANGE
+3 SET DIR(0)="SA^S:SINGLE ERA;A:ALL"
+4 SET DIR("A")="SELECT (S)ingle ERA or (A)LL: "
SET DIR("B")="ALL"
+5 DO ^DIR
+6 IF Y'="S"
IF Y'="A"
QUIT
+7 ; PRCA*4.5*326
SET RCALL=Y
+8 ;
+9 ; If Single ERA, select the ERA
+10 SET RCERA=""
SET RCTYPE="A"
+11 ; PRCA*4.5*326
IF RCALL="S"
SET RCERA=$$SELERA()
if 'RCERA
QUIT
GOTO RANGE
+12 ;
+13 ; If ALL ERAs, select Type of Payers to include and Date Range for Report
+14 ; PRCA*4.5*326
SET RCTYPE=$$RTYPE^RCDPEU1("A")
IF RCTYPE=-1
QUIT
+15 ;
RANGE ; Select date range for audit transactions
+1 SET RCRANGE=""
+2 SET RCRANGE=$$DTRNG()
IF 'RCRANGE
QUIT
+3 ;
+4 ; Prompt for device
+5 NEW %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
+6 SET %ZIS="QM"
+7 DO ^%ZIS
+8 IF POP
GOTO ENQ
+9 IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTRTN="RUN^RCDPEAPS(RCERA,RCRANGE)"
+11 SET ZTIO=ION
+12 SET ZTSAVE("*")=""
+13 SET ZTDESC="ERA STATUS CHANGE AUDIT REPORT"
+14 DO ^%ZTLOAD
+15 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+16 DO HOME^%ZIS
End DoDot:1
GOTO ENQ
+17 USE IO
+18 ;
+19 DO RUN(RCERA,RCRANGE)
+20 ;
ENQ ;
+1 QUIT
+2 ;
RUN(RCERA,RCRANGE) ;
+1 ;
+2 KILL ^TMP("RCDPEAPS",$JOB)
+3 ;
+4 ; Compile Data
+5 DO COMPILE(RCERA,RCRANGE)
+6 ;
+7 ; Generate Report
+8 DO REPORT(RCRANGE)
+9 ;
+10 KILL ^TMP("RCDPEAPS",$JOB)
+11 QUIT
+12 ;
COMPILE(RCERA,RCRANGE) ;
+1 ; Compile the data
+2 ;
+3 NEW CNT,BDATE,EDATE,AUDDATE,IEN,CNT,DATA
+4 SET CNT=0
SET BDATE=$PIECE(RCRANGE,U,1)-.000001
SET EDATE=$PIECE(RCRANGE,U,2)+.999999
+5 ;
+6 ; If RCERA is non-zero, then we are doing a single ERA
+7 IF RCERA
Begin DoDot:1
+8 SET IEN=""
FOR
SET IEN=$ORDER(^RCY(344.72,"E",RCERA,IEN))
if 'IEN
QUIT
Begin DoDot:2
+9 SET DATA=$GET(^RCY(344.72,IEN,0))
+10 SET AUDDATE=$PIECE(DATA,U,1)
+11 IF AUDDATE=""
QUIT
+12 IF AUDDATE<BDATE!(AUDDATE>EDATE)
QUIT
+13 SET CNT=CNT+1
+14 SET ^TMP("RCDPEAPS",$JOB,RCERA,AUDDATE,CNT)=$PIECE(DATA,U,4)_U_$PIECE(DATA,U,5)_U_$PIECE(DATA,U,2)_U_$PIECE(DATA,U,6)
End DoDot:2
End DoDot:1
QUIT
+15 ;
+16 ; If RCERA is zero, then we are gathering data by date
+17 IF 'RCERA
Begin DoDot:1
+18 SET AUDDATE=BDATE
FOR
SET AUDDATE=$ORDER(^RCY(344.72,"B",AUDDATE))
if 'AUDDATE!(AUDDATE>EDATE)
QUIT
Begin DoDot:2
+19 SET IEN=""
FOR
SET IEN=$ORDER(^RCY(344.72,"B",AUDDATE,IEN))
if 'IEN
QUIT
Begin DoDot:3
+20 SET DATA=$GET(^RCY(344.72,IEN,0))
+21 IF $PIECE(DATA,U,3)=""
QUIT
+22 SET CNT=CNT+1
+23 SET ^TMP("RCDPEAPS",$JOB,$PIECE(DATA,U,3),AUDDATE,CNT)=$PIECE(DATA,U,4)_U_$PIECE(DATA,U,5)_U_$PIECE(DATA,U,2)_U_$PIECE(DATA,U,6)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+24 QUIT
+25 ;
REPORT(RCRANGE) ;
+1 ; Display output
+2 ;
+3 ; Initialize Report Date, Page Number and Sting of underscores
+4 NEW RCSCR,RCNOW,RCPG,RCHR,ERA,DATE,CNT,DATA,LINES
+5 SET RCSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+6 SET RCNOW=$$UP^XLFSTR($$NOW^RCDPRU())
SET RCPG=0
SET RCHR=""
SET $PIECE(RCHR,"-",IOM+1)=""
+7 ;
+8 USE IO
+9 DO HEADER(RCNOW,.RCPG,RCHR,RCRANGE)
+10 IF '$DATA(^TMP("RCDPEAPS",$JOB))
WRITE !,"No data found"
+11 ;
+12 ; Display the detail
+13 SET ERA=""
FOR
SET ERA=$ORDER(^TMP("RCDPEAPS",$JOB,ERA))
if 'ERA
QUIT
Begin DoDot:1
+14 ; PRCA*4.5*326 Filter by Medical, Tricare or Pharmacy
IF RCTYPE'="A"
IF '$$ISTYPE^RCDPEU1(344.4,ERA,RCTYPE)
QUIT
+15 SET DATE=""
FOR
SET DATE=$ORDER(^TMP("RCDPEAPS",$JOB,ERA,DATE))
if 'DATE
QUIT
Begin DoDot:2
+16 SET CNT=0
FOR
SET CNT=$ORDER(^TMP("RCDPEAPS",$JOB,ERA,DATE,CNT))
if 'CNT
QUIT
Begin DoDot:3
+17 SET DATA=^TMP("RCDPEAPS",$JOB,ERA,DATE,CNT)
+18 SET LINES=2
+19 IF $PIECE(DATA,U,4)]""
SET LINES=3
+20 IF RCSCR
SET LINES=LINES+1
+21 DO CHKP(RCNOW,.RCPG,RCHR,RCRANGE,RCSCR,LINES)
IF RCPG=0
QUIT
+22 WRITE !,ERA,?15,$$FMTE^XLFDT(DATE,"2Z"),?38,$$STATUS($PIECE(DATA,U,1)),?49,$$STATUS($PIECE(DATA,U,2))
+23 WRITE ?63,$EXTRACT($$GET1^DIQ(200,+$PIECE(DATA,U,3)_",",.01),1,IOM-63)
+24 IF $PIECE(DATA,U,4)]""
WRITE !,?3,$EXTRACT($PIECE(DATA,U,4),1,IOM-4)
+25 WRITE !
End DoDot:3
IF RCPG=0
QUIT
End DoDot:2
IF RCPG=0
QUIT
End DoDot:1
IF RCPG=0
QUIT
+26 ;
+27 IF 'RCSCR
WRITE !,@IOF
+28 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+29 DO ^%ZISC
+30 ;
+31 IF RCPG
IF RCSCR
DO PAUSE
+32 QUIT
+33 ;
+1 ; Print Header
+2 ;
+3 NEW LINE
+4 WRITE @IOF
+5 SET RCPG=RCPG+1
+6 SET LINE="EDI Lockbox ERA Status Change Audit Report"
+7 WRITE ?(IOM-$LENGTH(LINE)\2),LINE
+8 SET LINE="Page: "_RCPG_" "
+9 WRITE ?(IOM-$LENGTH(LINE)),LINE
+10 SET LINE="RUN DATE: "_RCNOW
+11 SET LINE=LINE_" MEDICAL/PHARMACY/TRICARE: "
+12 SET LINE=LINE_$SELECT(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARAMCY",RCTYPE="T":"TRICARE",1:"ALL")
+13 WRITE !?(IOM-$LENGTH(LINE)\2),LINE
+14 SET LINE="DATE RANGE: "_$$FMTE^XLFDT($PIECE(RCRANGE,U,1),"5DZ")_" - "_$$FMTE^XLFDT($PIECE(RCRANGE,U,2),"5DZ")
+15 WRITE !?(IOM-$LENGTH(LINE)\2),LINE
+16 ;
+17 WRITE !!,"ERA#",?15,"Date/Time Edited",?38,"Status (Old/New)",?63,"User"
+18 WRITE !?3,"Reason Text"
+19 WRITE !,RCHR
+20 QUIT
+21 ;
PAUSE() ;
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT
+2 SET DIR(0)="E"
+3 DO ^DIR
+4 QUIT Y
+5 ;
CHKP(RCNOW,RCPG,RCHR,RCRANGE,RCSCR,LINES) ;
+1 ; Check if we need to do a page break
+2 ;
+3 IF $Y'>(IOSL-LINES)
QUIT
+4 IF RCSCR
IF '$$PAUSE
SET RCPG=0
QUIT
+5 DO HEADER(RCNOW,.RCPG,RCHR,RCRANGE)
+6 QUIT
+7 ;
SELERA() ;
+1 ; Lookup on the Electronic Remittance Advice (#344.4) file
+2 ;
+3 NEW DIC,X,Y,DTOUT,DUOUT
+4 SET DIC="^RCY(344.4,"
SET DIC(0)="QEAMn"
+5 DO ^DIC
+6 IF $GET(DTOUT)!$GET(DUOUT)!(Y=-1)
QUIT 0
+7 QUIT +Y
+8 ;
DTRNG() ;
+1 ; Get the date range for the report
+2 ;
+3 NEW DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,BDATE
+4 SET DIR("?")="ENTER THE EARLIEST AUDIT DATE TO INCLUDE ON THE REPORT"
+5 SET DIR(0)="DA^:"_DT_":APE"
SET DIR("A")="START DATE: "
SET DIR("B")="T"
DO ^DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET BDATE=-1
QUIT 0
+7 SET BDATE=Y
+8 KILL DIR
+9 SET DIR("?")="ENTER THE LATEST AUDIT DATE TO INCLUDE ON THE REPORT"
+10 SET DIR("B")=Y(0)
+11 SET DIR(0)="DA^"_BDATE_":"_DT_":APE"
SET DIR("A")="END DATE: "
SET DIR("B")="T"
DO ^DIR
+12 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
QUIT 0
+13 QUIT BDATE_"^"_Y
+14 ;
STATUS(STATUS) ;
+1 ; Convert internal status to external status
+2 IF '$DATA(STATUS)
QUIT ""
+3 IF STATUS=""
QUIT "NULL"
+4 QUIT $$EXTERNAL^DILFD(344.4,4.02,,STATUS)
