- 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 Mar 13, 2025@21:27:28 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
