IBFBWLR ;ALB/PAW-NVC and Billing Worklist Worklist History Report ;30-SEP-2015
;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- Main entry point for NVC and Billing Worklist History Report
N DFN,IBAUTH,IBC,IBDA,IBDB,IBDC,IBDL,IBDT,IBDTR,IBDT1,IBDT2,IBDTTM,IBDTTM1,IBDTTM2
N IBDUZ,IBEVNT,IBHDT,IBI,IBPG,IBQUIT,IBRANGE,IBX,X,Y
N ZTDESC,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSTOP,%ZIS,FIRST
D PROMPT
D PRINT
D EXIT
Q
;
PROMPT ; - Report prompts
; Can be run by PATIENT or DATE RANGE
S DIR(0)="S^P:Patient;D:Date Range"
S DIR("A")="Report by Patient or Date Range"
S DIR("B")="Date Range"
S DIR("?",1)="Enter P to print the worklist history data for one patient."
S DIR("?",2)="Enter D to print all worklist history data for a date range."
S DIR("?")="Enter a code from the list."
D ^DIR K DIR G:$D(DIRUT) EXIT
S IBRANGE=$S(Y="D":1,1:0)
;
I IBRANGE D G:$D(DIRUT) EXIT
. ; Ask dates
. S DIR(0)="D^::EX",DIR("A")="From Date"
. ; Default from date is first day of current month
. S DIR("B")=$$FMTE^XLFDT($E(DT,1,5)_"01")
. D ^DIR K DIR Q:$D(DIRUT)
. S IBDT1=Y
. I $G(IBDT1)="" Q
. S DIR(0)="DA^"_IBDT1_"::EX",DIR("A")="To Date: "
. ; Default to date is last day of specified month
. S X=$E($$SCH^XLFDT("1M(L@1A)",IBDT1)\1,6,7)
. S DIR("B")=$$FMTE^XLFDT($E(IBDT1,1,5)_X)
. D ^DIR K DIR Q:$D(DIRUT)
. S IBDT2=Y
. I $G(IBDT2)="" Q
;
; If not date range then ask patient
I 'IBRANGE D
. S DIC(0)="AEQMN",DIC="^DPT(",FIRST=1
. N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
. S DIC("A")=$S(FIRST:"Select Patient: ",1:"Select Another Patient: ")
. D ^DIC
. S DFN=$P(Y,U)
I 'IBRANGE,$G(DFN)'>0 Q
;
; Ask device
S %ZIS="QM" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
. S ZTRTN="QEN^IBFBWLR",ZTDESC="NVC/Billing Worklist History"
. F IBX="IBAAIN","IBDT*","IBRANGE" S ZTSAVE(IBX)=""
. D ^%ZTLOAD,HOME^%ZIS K ZTSK
QEN ; queued entry
U IO
Q
;
PRINT ; Report data
I '$D(IBRANGE) G EXIT
I IBRANGE I $G(IBDT1)=""!($G(IBDT2)="") G EXIT
I 'IBRANGE I $G(DFN)'>0 G EXIT
S IBQUIT=0
S IBPG=0 D NOW^%DTC S Y=% D DD^%DT S IBDTR=Y
K IBDL S IBDL="",$P(IBDL,"-",IOM)=""
;
; Build page header text for selection criteria
S:IBRANGE IBHDT(1)=" For "_$$FMTE^XLFDT(IBDT1)_" through "_$$FMTE^XLFDT(IBDT2)
;
D HD
;
; Initialize Counter
S IBC=0
;
; If by date range
I IBRANGE D
. S IBDT=IBDT1-.0000001
. F S IBDT=$O(^IBFB(360,"DT",IBDT)) Q:'IBDT!(IBDT>(IBDT2_".999999")) D Q:IBQUIT
.. S IBDA="" F S IBDA=$O(^IBFB(360,"DT",IBDT,IBDA)) Q:'IBDA D Q:IBQUIT
... S IBDB="" F S IBDB=$O(^IBFB(360,"DT",IBDT,IBDA,IBDB)) Q:'IBDB D Q:IBQUIT
.... S IBDC="" F S IBDC=$O(^IBFB(360,"DT",IBDT,IBDA,IBDB,IBDC)) Q:'IBDC D Q:IBQUIT
..... S DFN=IBDA
..... D SETVARS
..... D PRINT1
;
; If by patient
I 'IBRANGE D
. S IBDA="" F S IBDA=$O(^IBFB(360,"DFN",DFN,IBDA)) Q:'IBDA D Q:IBQUIT
.. S IBDB="" F S IBDB=$O(^IBFB(360,"DFN",DFN,IBDA,IBDB)) Q:'IBDB D Q:IBQUIT
... S IBDC="" F S IBDC=$O(^IBFB(360,"DFN",DFN,IBDA,IBDB,IBDC)) Q:'IBDC D Q:IBQUIT
.... D SETVARS
.... D PRINT1
;
I IBC=0 W !,"No worklist history entries found."
;
I IBQUIT W !!,"REPORT STOPPED AT USER REQUEST"
;
I 'IBQUIT,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
D ^%ZISC
Q
;
SETVARS ; Set variables
S IBDTTM=$P($G(^IBFB(360,IBDB,4,IBDC,0)),U,1)
S IBDTTM1=$P(IBDTTM,".",1)
I IBDTTM1'="" S IBDTTM1=$$FDATE^VALM1(IBDTTM1)
S Y=IBDTTM D DD^%DT S IBDTTM2=Y
S IBDTTM2=$P($G(IBDTTM2),"@",2)
S IBDTTM2=$P(IBDTTM2,":",1,2)
S IBEVNT=$P($P($G(^IBFB(360,IBDB,4,IBDC,0)),U,2),"|")
I IBEVNT["RUR-NextRevDt" S IBEVNT=$P(IBEVNT,"/",1,2)
S IBDUZ=$P($G(^IBFB(360,IBDB,4,IBDC,0)),U,3)
S IBAUTH=$P($G(^IBFB(360,IBDB,0)),U,3)
Q
;
HD ; Page header
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,IBQUIT=1 Q
I $E(IOST,1,2)="C-",IBPG S DIR(0)="E" D ^DIR K DIR I 'Y S IBQUIT=1 Q
I $E(IOST,1,2)="C-"!IBPG W @IOF
S IBPG=IBPG+1
W !,"NVC/Billing Worklist History "
I IBRANGE W "by Date Range"
E W "by Patient"
W ?49,IBDTR,?72,"page ",IBPG
S IBI=0 F S IBI=$O(IBHDT(IBI)) Q:'IBI W !,IBHDT(IBI)
W !!,"Date/Time",?15,"Patient",?38,"Auth",?43,"Event",?64,"User"
W !,IBDL
Q
;
PRINT1 ; Print one history record
N IBCNT,IBRUR,IBRURT,IBRURTX
S IBC=IBC+1
I $Y+9>IOSL D HD Q:IBQUIT
W !,IBDTTM1_"@"_IBDTTM2,?15,$E($$GET1^DIQ(2,DFN_",",.01),1,22),?38,IBAUTH,?43,$E(IBEVNT,1,20),?64,$E($$GET1^DIQ(200,IBDUZ_",",.01),1,15)
I $P($P($G(^IBFB(360,IBDB,4,IBDC,0)),U,2),"|",2)'="" D
. S IBRURT=""
. S IBRUR=$P($P(^IBFB(360,IBDB,4,IBDC,0),U,2),"|",2)
. S IBRURT=$S(IBRUR=1:"Pending Payer Action",IBRUR=2:"Addl Info Req - Refer to FR",IBRUR=3:"Auth Not Required - SC/SA",IBRUR=4:"Auth Not Required - Payer Contacted",1:"")
. Q:IBRURT'=""
. S IBRURT=$S(IBRUR=5:"Auth Not Required",IBRUR=6:"Auth Obtained",IBRUR=7:"Continued Stay Review",IBRUR=8:"Discharge Review Required",1:"")
. Q:IBRURT'=""
. S IBRURT=$S(IBRUR=9:"Partial SC Stay - Auth Worked",IBRUR=10:"Partial Stay / Visit Approved",IBRUR=11:"Auth Denied",1:"")
. Q:IBRURT'=""
. S IBRURT=$S(IBRUR=12:"Auth Not Obtained / No ROI / Sent to FR",IBRUR=13:"EOC SC/SA",IBRUR=14:"EOC Non SC/SA",1:"")
. Q:IBRURT'=""
. S IBRURT=$S(IBRUR=15:"Need Addl Info - Refer to FR",IBRUR=16:"EOC Related to Legal",IBRUR=17:"EOC Not Related to Legal - No OHI",1:"")
. Q:IBRURT'=""
. S IBRURT=$S(IBRUR=18:"EOC Not Related to Legal - OHI SC/SA",IBRUR=19:"EOC Not Related to Legal - OHI Non SC/SA",1:"")
I $G(IBRURT)'="" W !?4,"RUR: ",IBRURT
Q
;
EXIT ;
I $D(ZTQUEUED) S ZTREQ="@"
K %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,J,POP,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBFBWLR 5718 printed Sep 23, 2025@19:58:47 Page 2
IBFBWLR ;ALB/PAW-NVC and Billing Worklist Worklist History Report ;30-SEP-2015
+1 ;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- Main entry point for NVC and Billing Worklist History Report
+1 NEW DFN,IBAUTH,IBC,IBDA,IBDB,IBDC,IBDL,IBDT,IBDTR,IBDT1,IBDT2,IBDTTM,IBDTTM1,IBDTTM2
+2 NEW IBDUZ,IBEVNT,IBHDT,IBI,IBPG,IBQUIT,IBRANGE,IBX,X,Y
+3 NEW ZTDESC,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSTOP,%ZIS,FIRST
+4 DO PROMPT
+5 DO PRINT
+6 DO EXIT
+7 QUIT
+8 ;
PROMPT ; - Report prompts
+1 ; Can be run by PATIENT or DATE RANGE
+2 SET DIR(0)="S^P:Patient;D:Date Range"
+3 SET DIR("A")="Report by Patient or Date Range"
+4 SET DIR("B")="Date Range"
+5 SET DIR("?",1)="Enter P to print the worklist history data for one patient."
+6 SET DIR("?",2)="Enter D to print all worklist history data for a date range."
+7 SET DIR("?")="Enter a code from the list."
+8 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
+9 SET IBRANGE=$SELECT(Y="D":1,1:0)
+10 ;
+11 IF IBRANGE
Begin DoDot:1
+12 ; Ask dates
+13 SET DIR(0)="D^::EX"
SET DIR("A")="From Date"
+14 ; Default from date is first day of current month
+15 SET DIR("B")=$$FMTE^XLFDT($EXTRACT(DT,1,5)_"01")
+16 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+17 SET IBDT1=Y
+18 IF $GET(IBDT1)=""
QUIT
+19 SET DIR(0)="DA^"_IBDT1_"::EX"
SET DIR("A")="To Date: "
+20 ; Default to date is last day of specified month
+21 SET X=$EXTRACT($$SCH^XLFDT("1M(L@1A)",IBDT1)\1,6,7)
+22 SET DIR("B")=$$FMTE^XLFDT($EXTRACT(IBDT1,1,5)_X)
+23 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+24 SET IBDT2=Y
+25 IF $GET(IBDT2)=""
QUIT
End DoDot:1
if $DATA(DIRUT)
GOTO EXIT
+26 ;
+27 ; If not date range then ask patient
+28 IF 'IBRANGE
Begin DoDot:1
+29 SET DIC(0)="AEQMN"
SET DIC="^DPT("
SET FIRST=1
+30 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+31 SET DIC("A")=$SELECT(FIRST:"Select Patient: ",1:"Select Another Patient: ")
+32 DO ^DIC
+33 SET DFN=$PIECE(Y,U)
End DoDot:1
+34 IF 'IBRANGE
IF $GET(DFN)'>0
QUIT
+35 ;
+36 ; Ask device
+37 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EXIT
+38 IF $DATA(IO("Q"))
Begin DoDot:1
+39 SET ZTRTN="QEN^IBFBWLR"
SET ZTDESC="NVC/Billing Worklist History"
+40 FOR IBX="IBAAIN","IBDT*","IBRANGE"
SET ZTSAVE(IBX)=""
+41 DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
End DoDot:1
GOTO EXIT
QEN ; queued entry
+1 USE IO
+2 QUIT
+3 ;
PRINT ; Report data
+1 IF '$DATA(IBRANGE)
GOTO EXIT
+2 IF IBRANGE
IF $GET(IBDT1)=""!($GET(IBDT2)="")
GOTO EXIT
+3 IF 'IBRANGE
IF $GET(DFN)'>0
GOTO EXIT
+4 SET IBQUIT=0
+5 SET IBPG=0
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET IBDTR=Y
+6 KILL IBDL
SET IBDL=""
SET $PIECE(IBDL,"-",IOM)=""
+7 ;
+8 ; Build page header text for selection criteria
+9 if IBRANGE
SET IBHDT(1)=" For "_$$FMTE^XLFDT(IBDT1)_" through "_$$FMTE^XLFDT(IBDT2)
+10 ;
+11 DO HD
+12 ;
+13 ; Initialize Counter
+14 SET IBC=0
+15 ;
+16 ; If by date range
+17 IF IBRANGE
Begin DoDot:1
+18 SET IBDT=IBDT1-.0000001
+19 FOR
SET IBDT=$ORDER(^IBFB(360,"DT",IBDT))
if 'IBDT!(IBDT>(IBDT2_".999999"))
QUIT
Begin DoDot:2
+20 SET IBDA=""
FOR
SET IBDA=$ORDER(^IBFB(360,"DT",IBDT,IBDA))
if 'IBDA
QUIT
Begin DoDot:3
+21 SET IBDB=""
FOR
SET IBDB=$ORDER(^IBFB(360,"DT",IBDT,IBDA,IBDB))
if 'IBDB
QUIT
Begin DoDot:4
+22 SET IBDC=""
FOR
SET IBDC=$ORDER(^IBFB(360,"DT",IBDT,IBDA,IBDB,IBDC))
if 'IBDC
QUIT
Begin DoDot:5
+23 SET DFN=IBDA
+24 DO SETVARS
+25 DO PRINT1
End DoDot:5
if IBQUIT
QUIT
End DoDot:4
if IBQUIT
QUIT
End DoDot:3
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
+26 ;
+27 ; If by patient
+28 IF 'IBRANGE
Begin DoDot:1
+29 SET IBDA=""
FOR
SET IBDA=$ORDER(^IBFB(360,"DFN",DFN,IBDA))
if 'IBDA
QUIT
Begin DoDot:2
+30 SET IBDB=""
FOR
SET IBDB=$ORDER(^IBFB(360,"DFN",DFN,IBDA,IBDB))
if 'IBDB
QUIT
Begin DoDot:3
+31 SET IBDC=""
FOR
SET IBDC=$ORDER(^IBFB(360,"DFN",DFN,IBDA,IBDB,IBDC))
if 'IBDC
QUIT
Begin DoDot:4
+32 DO SETVARS
+33 DO PRINT1
End DoDot:4
if IBQUIT
QUIT
End DoDot:3
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
+34 ;
+35 IF IBC=0
WRITE !,"No worklist history entries found."
+36 ;
+37 IF IBQUIT
WRITE !!,"REPORT STOPPED AT USER REQUEST"
+38 ;
+39 IF 'IBQUIT
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+40 DO ^%ZISC
+41 QUIT
+42 ;
SETVARS ; Set variables
+1 SET IBDTTM=$PIECE($GET(^IBFB(360,IBDB,4,IBDC,0)),U,1)
+2 SET IBDTTM1=$PIECE(IBDTTM,".",1)
+3 IF IBDTTM1'=""
SET IBDTTM1=$$FDATE^VALM1(IBDTTM1)
+4 SET Y=IBDTTM
DO DD^%DT
SET IBDTTM2=Y
+5 SET IBDTTM2=$PIECE($GET(IBDTTM2),"@",2)
+6 SET IBDTTM2=$PIECE(IBDTTM2,":",1,2)
+7 SET IBEVNT=$PIECE($PIECE($GET(^IBFB(360,IBDB,4,IBDC,0)),U,2),"|")
+8 IF IBEVNT["RUR-NextRevDt"
SET IBEVNT=$PIECE(IBEVNT,"/",1,2)
+9 SET IBDUZ=$PIECE($GET(^IBFB(360,IBDB,4,IBDC,0)),U,3)
+10 SET IBAUTH=$PIECE($GET(^IBFB(360,IBDB,0)),U,3)
+11 QUIT
+12 ;
HD ; Page header
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET IBQUIT=1
QUIT
+2 IF $EXTRACT(IOST,1,2)="C-"
IF IBPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET IBQUIT=1
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"!IBPG
WRITE @IOF
+4 SET IBPG=IBPG+1
+5 WRITE !,"NVC/Billing Worklist History "
+6 IF IBRANGE
WRITE "by Date Range"
+7 IF '$TEST
WRITE "by Patient"
+8 WRITE ?49,IBDTR,?72,"page ",IBPG
+9 SET IBI=0
FOR
SET IBI=$ORDER(IBHDT(IBI))
if 'IBI
QUIT
WRITE !,IBHDT(IBI)
+10 WRITE !!,"Date/Time",?15,"Patient",?38,"Auth",?43,"Event",?64,"User"
+11 WRITE !,IBDL
+12 QUIT
+13 ;
PRINT1 ; Print one history record
+1 NEW IBCNT,IBRUR,IBRURT,IBRURTX
+2 SET IBC=IBC+1
+3 IF $Y+9>IOSL
DO HD
if IBQUIT
QUIT
+4 WRITE !,IBDTTM1_"@"_IBDTTM2,?15,$EXTRACT($$GET1^DIQ(2,DFN_",",.01),1,22),?38,IBAUTH,?43,$EXTRACT(IBEVNT,1,20),?64,$EXTRACT($$GET1^DIQ(200,IBDUZ_",",.01),1,15)
+5 IF $PIECE($PIECE($GET(^IBFB(360,IBDB,4,IBDC,0)),U,2),"|",2)'=""
Begin DoDot:1
+6 SET IBRURT=""
+7 SET IBRUR=$PIECE($PIECE(^IBFB(360,IBDB,4,IBDC,0),U,2),"|",2)
+8 SET IBRURT=$SELECT(IBRUR=1:"Pending Payer Action",IBRUR=2:"Addl Info Req - Refer to FR",IBRUR=3:"Auth Not Required - SC/SA",IBRUR=4:"Auth Not Required - Payer Contacted",1:"")
+9 if IBRURT'=""
QUIT
+10 SET IBRURT=$SELECT(IBRUR=5:"Auth Not Required",IBRUR=6:"Auth Obtained",IBRUR=7:"Continued Stay Review",IBRUR=8:"Discharge Review Required",1:"")
+11 if IBRURT'=""
QUIT
+12 SET IBRURT=$SELECT(IBRUR=9:"Partial SC Stay - Auth Worked",IBRUR=10:"Partial Stay / Visit Approved",IBRUR=11:"Auth Denied",1:"")
+13 if IBRURT'=""
QUIT
+14 SET IBRURT=$SELECT(IBRUR=12:"Auth Not Obtained / No ROI / Sent to FR",IBRUR=13:"EOC SC/SA",IBRUR=14:"EOC Non SC/SA",1:"")
+15 if IBRURT'=""
QUIT
+16 SET IBRURT=$SELECT(IBRUR=15:"Need Addl Info - Refer to FR",IBRUR=16:"EOC Related to Legal",IBRUR=17:"EOC Not Related to Legal - No OHI",1:"")
+17 if IBRURT'=""
QUIT
+18 SET IBRURT=$SELECT(IBRUR=18:"EOC Not Related to Legal - OHI SC/SA",IBRUR=19:"EOC Not Related to Legal - OHI Non SC/SA",1:"")
End DoDot:1
+19 IF $GET(IBRURT)'=""
WRITE !?4,"RUR: ",IBRURT
+20 QUIT
+21 ;
EXIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,J,POP,X,Y
+3 QUIT
