IBFBWL6 ;ALB/PAW-IB NVC Precert Worklist IV and RUR ;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 IB NVC PRECERT WORKLIST IV and RUR
; add code to do filters here
;
I IBGRP=1 D EN^VALM("IB NVC PRECERT WORKLIST IV")
I IBGRP=2 D EN^VALM("IB NVC PRECERT WORKLIST RUR")
Q
;
HDR ; -- header code
;
N IBSS,IBSSX,IBSSLE,IBSSLS
S VALM("TITLE")=" Worklist Actions"
S IBSSX=$$GET1^DIQ(2,DFN_",",.09,"I"),IBSSLE=$L(IBSSX),IBSSLS=6 I $E(IBSSX,IBSSLE)="P" S IBSSLS=5
S IBSS=$E(IBNAME,1)_$E(IBSSX,IBSSLS,IBSSLE)
S VALMHDR(2)=" PATIENT: "_IBNAME_" (ID: "_IBSS_")"
Q
;
INIT ; -- init variables and list array
; input - ^TMP("IBFBWA",$J)=DFN^IBNAME^IBAUTH
; output - none
N DFN,ECNT,IBAUTH,IBNAME,IBFIRST
I '$D(^TMP("IBFBWA",$J)) Q
S ECNT=$G(^TMP("IBFBWA",$J))
S DFN=$P(ECNT,U,1),IBNAME=$P(ECNT,U,2),IBAUTH=$P(ECNT,U,3)
D BLD
Q
;
BLD ; Build data to display
N IBGRPX,VALMY
I $G(IBFIRST)'="" S IBFIRST="" Q
D FULL^VALM1
S IBGRPX=$S(IBGRP=1:"Insurance Verification",1:"RUR Pre-certification")
I IBGRP=1 D
. D SET^VALM10(1,"","")
. D SET^VALM10(2," Available Actions:","")
. D SET^VALM10(3,"","")
. D SET^VALM10(4," Enter 1 if Pre-cert is required.","")
. D SET^VALM10(5," Enter 2 if Pre-cert is NOT required.","")
I IBGRP=2 D
. D SET^VALM10(1,"Available Actions:","")
. D SET^VALM10(2,"","")
. D SET^VALM10(3," Enter 1 to remove auth from worklist.","")
. D SET^VALM10(4," Enter 2 to complete certification.","")
. D SET^VALM10(5," Enter 3 to set a next review date.","")
. D RURRC
S VALMBCK="R"
Q
;
IVDONE ; IV is complete
N IBEVENT,IBIEN,IENROOT
I $G(IBFIRST)'="" S IBFIRST="" Q
S IENROOT=""
D FIND
S FDA(360,IBIEN_",",2.01)="XX"
D UPDATE^DIE("","FDA","IENROOT")
S FDA(360,IBIEN_",",2.02)="UR"
D UPDATE^DIE("","FDA","IENROOT")
D RESET
D NOW^%DTC
S IBEVENT="IV-Req Precert"
D LOGUPD
W !," Pre-cert for "_IBNAME_" is required. Moved to RUR worklist."
S IBFIRST=1
D PAUSE^VALM1
S VALMBCK="R"
Q
;
IVREM ; IV Remove Auth from Worklist
N IBEVENT,IBIEN,IENROOT
I $G(IBFIRST)'="" S IBFIRST="" Q
D FIND
S FDA(360,IBIEN_",",2.01)="XX"
D UPDATE^DIE("","FDA","IENROOT")
D RESET
D NOW^%DTC
S IBEVENT="IV-Precert not req"
D LOGUPD
W !," Pre-cert for "_IBNAME_" not required. Removed from worklist."
S IBFIRST=1
D PAUSE^VALM1
S VALMBCK="R"
Q
;
RUDONE ; RUR Pre-certification is complete
N IBEVENT,IBIEN,IBRC,IENROOT
I $G(IBFIRST)'="" S IBFIRST="" Q
D FIND
S FDA(360,IBIEN_",",2.02)="XX"
D UPDATE^DIE("","FDA","IENROOT")
D RESET
D RURRCPR
D NOW^%DTC
S IBEVENT="RUR-Precert complete|"_$G(IBRC)
D LOGUPD
W !," Authorization for "_IBNAME_" has completed RUR Pre-certification."
S IBFIRST=1
D PAUSE^VALM1
S VALMBCK="R"
Q
;
RUREM ; RUR Remove Auth from Worklist
N IBEVENT,IBIEN,IBRC
I $G(IBFIRST)'="" S IBFIRST="" Q
D FIND
S FDA(360,IBIEN_",",2.02)="XX"
D UPDATE^DIE("","FDA","IENROOT")
D RESET
D RURRCPR
D NOW^%DTC
S IBEVENT="RUR-Precert removed|"_$G(IBRC)
D LOGUPD
W !," Authorization for "_IBNAME_" has been removed from the worklist."
; W !," Please update Claims Tracking with Non-billable Reason, if needed."
S IBFIRST=1
D PAUSE^VALM1
S VALMBCK="R"
Q
;
RUNRD ; RUR Set Next Review Date
N DIRUT,IBNRD,IBIEN,IENROOT,X,Y,IBEVENT,IBRC
I $G(IBFIRST)'="" S IBFIRST="" Q
S (IBNRD,IENROOT)=""
D FIND
S DIR(0)="DA^"_DT_"::EX",DIR("A")="Next Review Date: "
; default to date is last day of current month
S X=$E($$SCH^XLFDT("1M(L@1A)",DT)\1,6,7)
S DIR("B")=$$FMTE^XLFDT($E(DT,1,5)_X)
D ^DIR K DIR Q:$D(DIRUT)
S IBNRD=Y
S FDA(360,IBIEN_",",3.01)=IBNRD
D UPDATE^DIE("","FDA","IENROOT")
D RESET
D RURRCPR
D NOW^%DTC
S IBEVENT="RUR-NextRevDt "_$$FDATE^VALM1(IBNRD)_"|"_$G(IBRC)
D LOGUPD
W !," Next review date for "_IBNAME_" has been set to "_$$FDATE^VALM1(IBNRD)_"."
S IBFIRST=1
D PAUSE^VALM1
S VALMBCK="R"
Q
;
FIND ; Find Auth Match
N IBX
S IBX="" F S IBX=$O(^IBFB(360,"C",DFN,IBX)) Q:IBX="" D
. I $P(^IBFB(360,IBX,0),U,3)=IBAUTH S IBIEN=IBX
Q
;
LOGUPD ; Update Log
N FDA,IBDT,IBLOG
S IBDT=$$NOW^XLFDT()
S FDA(360.04,"+1,"_IBIEN_",",.01)=IBDT,FDA(360.04,"+1,"_IBIEN_",",.03)=DUZ
S IBLOG=$P($G(^IBFB(360,IBIEN,4,0)),U,3)
S IBLOG=IBLOG+1
S FDA(360.04,"+1,"_IBIEN_",",.02)=IBEVENT
D UPDATE^DIE("","FDA")
S ^IBFB(360,"DFN",DFN,DT,IBIEN,IBLOG)=""
S ^IBFB(360,"DT",DT,DFN,IBIEN,IBLOG)=""
Q
;
RESET ; Reset ^TMP global
N IBDOS,IBINS
I IBGRP=1 D
. S IBINS=""
. F S IBINS=$O(^TMP("IBFBWL",$J,IBINS)) Q:IBINS="" D
.. I $D(^TMP("IBFBWL",$J,IBINS,IBNAME,DFN,IBAUTH)) D
... K ^TMP("IBFBWL",$J,IBINS,IBNAME,DFN,IBAUTH)
I IBGRP=2 D
. S IBDOS=""
. F S IBDOS=$O(^TMP("IBFBWL",$J,IBDOS)) Q:IBDOS="" D
.. S IBINS="" F S IBINS=$O(^TMP("IBFBWL",$J,IBDOS,IBINS)) Q:IBINS="" D
... I $D(^TMP("IBFBWL",$J,IBDOS,IBINS,IBNAME,DFN,IBAUTH)) D
.... K ^TMP("IBFBWL",$J,IBDOS,IBINS,IBNAME,DFN,IBAUTH)
Q
;
RURRC ; Reason Codes
; Option 2 (internal comment 2) was removed - Addl Info Req - Refer to FR - and renumbered
D SET^VALM10(6,"","")
D SET^VALM10(7," At the second prompt, you may enter one of the following:","")
D SET^VALM10(8,"","")
D SET^VALM10(9," 1. Pending Payer Action 6. Continued Stay Review","")
D SET^VALM10(10," 2. Auth Not Reqd - SC/SA 7. Discharge Review Required","")
D SET^VALM10(11," 3. Auth Not Reqd - Payer Contacted 8. Partial SC Stay - Auth Worked","")
D SET^VALM10(12," 4. Auth Not Required 9. Partial Stay/Visit Approved","")
D SET^VALM10(13," 5. Auth Obtained 10. Auth Denied","")
D SET^VALM10(14," 11. Auth Not Obtained/No ROI/Sent to FR","")
Q
;
RURRCPR ; RUR Reason Code Prompt
N X,Y
S IBRC=""
K DIR S DIR(0)="NO^1:11"
S DIR("A")="Enter REASON CODE (1-11) or return: "
S DIR("?",1)="Enter a Reason Code between 1 and 11 or Enter if no code."
D ^DIR K DIR
S IBRC=$G(Y)
I IBRC="^" W !,"This response must be a number." G RURRCPR
S IBRC=$S(IBRC=1:1,IBRC=2:3,IBRC=3:4,IBRC=4:5,IBRC=5:6,IBRC=6:7,IBRC=7:8,IBRC=8:9,IBRC=9:10,IBRC=10:11,IBRC=11:12,1:"")
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D ^%ZISC
S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBFBWL6 6442 printed Dec 13, 2024@02:22:29 Page 2
IBFBWL6 ;ALB/PAW-IB NVC Precert Worklist IV and RUR ;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 IB NVC PRECERT WORKLIST IV and RUR
+1 ; add code to do filters here
+2 ;
+3 IF IBGRP=1
DO EN^VALM("IB NVC PRECERT WORKLIST IV")
+4 IF IBGRP=2
DO EN^VALM("IB NVC PRECERT WORKLIST RUR")
+5 QUIT
+6 ;
HDR ; -- header code
+1 ;
+2 NEW IBSS,IBSSX,IBSSLE,IBSSLS
+3 SET VALM("TITLE")=" Worklist Actions"
+4 SET IBSSX=$$GET1^DIQ(2,DFN_",",.09,"I")
SET IBSSLE=$LENGTH(IBSSX)
SET IBSSLS=6
IF $EXTRACT(IBSSX,IBSSLE)="P"
SET IBSSLS=5
+5 SET IBSS=$EXTRACT(IBNAME,1)_$EXTRACT(IBSSX,IBSSLS,IBSSLE)
+6 SET VALMHDR(2)=" PATIENT: "_IBNAME_" (ID: "_IBSS_")"
+7 QUIT
+8 ;
INIT ; -- init variables and list array
+1 ; input - ^TMP("IBFBWA",$J)=DFN^IBNAME^IBAUTH
+2 ; output - none
+3 NEW DFN,ECNT,IBAUTH,IBNAME,IBFIRST
+4 IF '$DATA(^TMP("IBFBWA",$JOB))
QUIT
+5 SET ECNT=$GET(^TMP("IBFBWA",$JOB))
+6 SET DFN=$PIECE(ECNT,U,1)
SET IBNAME=$PIECE(ECNT,U,2)
SET IBAUTH=$PIECE(ECNT,U,3)
+7 DO BLD
+8 QUIT
+9 ;
BLD ; Build data to display
+1 NEW IBGRPX,VALMY
+2 IF $GET(IBFIRST)'=""
SET IBFIRST=""
QUIT
+3 DO FULL^VALM1
+4 SET IBGRPX=$SELECT(IBGRP=1:"Insurance Verification",1:"RUR Pre-certification")
+5 IF IBGRP=1
Begin DoDot:1
+6 DO SET^VALM10(1,"","")
+7 DO SET^VALM10(2," Available Actions:","")
+8 DO SET^VALM10(3,"","")
+9 DO SET^VALM10(4," Enter 1 if Pre-cert is required.","")
+10 DO SET^VALM10(5," Enter 2 if Pre-cert is NOT required.","")
End DoDot:1
+11 IF IBGRP=2
Begin DoDot:1
+12 DO SET^VALM10(1,"Available Actions:","")
+13 DO SET^VALM10(2,"","")
+14 DO SET^VALM10(3," Enter 1 to remove auth from worklist.","")
+15 DO SET^VALM10(4," Enter 2 to complete certification.","")
+16 DO SET^VALM10(5," Enter 3 to set a next review date.","")
+17 DO RURRC
End DoDot:1
+18 SET VALMBCK="R"
+19 QUIT
+20 ;
IVDONE ; IV is complete
+1 NEW IBEVENT,IBIEN,IENROOT
+2 IF $GET(IBFIRST)'=""
SET IBFIRST=""
QUIT
+3 SET IENROOT=""
+4 DO FIND
+5 SET FDA(360,IBIEN_",",2.01)="XX"
+6 DO UPDATE^DIE("","FDA","IENROOT")
+7 SET FDA(360,IBIEN_",",2.02)="UR"
+8 DO UPDATE^DIE("","FDA","IENROOT")
+9 DO RESET
+10 DO NOW^%DTC
+11 SET IBEVENT="IV-Req Precert"
+12 DO LOGUPD
+13 WRITE !," Pre-cert for "_IBNAME_" is required. Moved to RUR worklist."
+14 SET IBFIRST=1
+15 DO PAUSE^VALM1
+16 SET VALMBCK="R"
+17 QUIT
+18 ;
IVREM ; IV Remove Auth from Worklist
+1 NEW IBEVENT,IBIEN,IENROOT
+2 IF $GET(IBFIRST)'=""
SET IBFIRST=""
QUIT
+3 DO FIND
+4 SET FDA(360,IBIEN_",",2.01)="XX"
+5 DO UPDATE^DIE("","FDA","IENROOT")
+6 DO RESET
+7 DO NOW^%DTC
+8 SET IBEVENT="IV-Precert not req"
+9 DO LOGUPD
+10 WRITE !," Pre-cert for "_IBNAME_" not required. Removed from worklist."
+11 SET IBFIRST=1
+12 DO PAUSE^VALM1
+13 SET VALMBCK="R"
+14 QUIT
+15 ;
RUDONE ; RUR Pre-certification is complete
+1 NEW IBEVENT,IBIEN,IBRC,IENROOT
+2 IF $GET(IBFIRST)'=""
SET IBFIRST=""
QUIT
+3 DO FIND
+4 SET FDA(360,IBIEN_",",2.02)="XX"
+5 DO UPDATE^DIE("","FDA","IENROOT")
+6 DO RESET
+7 DO RURRCPR
+8 DO NOW^%DTC
+9 SET IBEVENT="RUR-Precert complete|"_$GET(IBRC)
+10 DO LOGUPD
+11 WRITE !," Authorization for "_IBNAME_" has completed RUR Pre-certification."
+12 SET IBFIRST=1
+13 DO PAUSE^VALM1
+14 SET VALMBCK="R"
+15 QUIT
+16 ;
RUREM ; RUR Remove Auth from Worklist
+1 NEW IBEVENT,IBIEN,IBRC
+2 IF $GET(IBFIRST)'=""
SET IBFIRST=""
QUIT
+3 DO FIND
+4 SET FDA(360,IBIEN_",",2.02)="XX"
+5 DO UPDATE^DIE("","FDA","IENROOT")
+6 DO RESET
+7 DO RURRCPR
+8 DO NOW^%DTC
+9 SET IBEVENT="RUR-Precert removed|"_$GET(IBRC)
+10 DO LOGUPD
+11 WRITE !," Authorization for "_IBNAME_" has been removed from the worklist."
+12 ; W !," Please update Claims Tracking with Non-billable Reason, if needed."
+13 SET IBFIRST=1
+14 DO PAUSE^VALM1
+15 SET VALMBCK="R"
+16 QUIT
+17 ;
RUNRD ; RUR Set Next Review Date
+1 NEW DIRUT,IBNRD,IBIEN,IENROOT,X,Y,IBEVENT,IBRC
+2 IF $GET(IBFIRST)'=""
SET IBFIRST=""
QUIT
+3 SET (IBNRD,IENROOT)=""
+4 DO FIND
+5 SET DIR(0)="DA^"_DT_"::EX"
SET DIR("A")="Next Review Date: "
+6 ; default to date is last day of current month
+7 SET X=$EXTRACT($$SCH^XLFDT("1M(L@1A)",DT)\1,6,7)
+8 SET DIR("B")=$$FMTE^XLFDT($EXTRACT(DT,1,5)_X)
+9 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+10 SET IBNRD=Y
+11 SET FDA(360,IBIEN_",",3.01)=IBNRD
+12 DO UPDATE^DIE("","FDA","IENROOT")
+13 DO RESET
+14 DO RURRCPR
+15 DO NOW^%DTC
+16 SET IBEVENT="RUR-NextRevDt "_$$FDATE^VALM1(IBNRD)_"|"_$GET(IBRC)
+17 DO LOGUPD
+18 WRITE !," Next review date for "_IBNAME_" has been set to "_$$FDATE^VALM1(IBNRD)_"."
+19 SET IBFIRST=1
+20 DO PAUSE^VALM1
+21 SET VALMBCK="R"
+22 QUIT
+23 ;
FIND ; Find Auth Match
+1 NEW IBX
+2 SET IBX=""
FOR
SET IBX=$ORDER(^IBFB(360,"C",DFN,IBX))
if IBX=""
QUIT
Begin DoDot:1
+3 IF $PIECE(^IBFB(360,IBX,0),U,3)=IBAUTH
SET IBIEN=IBX
End DoDot:1
+4 QUIT
+5 ;
LOGUPD ; Update Log
+1 NEW FDA,IBDT,IBLOG
+2 SET IBDT=$$NOW^XLFDT()
+3 SET FDA(360.04,"+1,"_IBIEN_",",.01)=IBDT
SET FDA(360.04,"+1,"_IBIEN_",",.03)=DUZ
+4 SET IBLOG=$PIECE($GET(^IBFB(360,IBIEN,4,0)),U,3)
+5 SET IBLOG=IBLOG+1
+6 SET FDA(360.04,"+1,"_IBIEN_",",.02)=IBEVENT
+7 DO UPDATE^DIE("","FDA")
+8 SET ^IBFB(360,"DFN",DFN,DT,IBIEN,IBLOG)=""
+9 SET ^IBFB(360,"DT",DT,DFN,IBIEN,IBLOG)=""
+10 QUIT
+11 ;
RESET ; Reset ^TMP global
+1 NEW IBDOS,IBINS
+2 IF IBGRP=1
Begin DoDot:1
+3 SET IBINS=""
+4 FOR
SET IBINS=$ORDER(^TMP("IBFBWL",$JOB,IBINS))
if IBINS=""
QUIT
Begin DoDot:2
+5 IF $DATA(^TMP("IBFBWL",$JOB,IBINS,IBNAME,DFN,IBAUTH))
Begin DoDot:3
+6 KILL ^TMP("IBFBWL",$JOB,IBINS,IBNAME,DFN,IBAUTH)
End DoDot:3
End DoDot:2
End DoDot:1
+7 IF IBGRP=2
Begin DoDot:1
+8 SET IBDOS=""
+9 FOR
SET IBDOS=$ORDER(^TMP("IBFBWL",$JOB,IBDOS))
if IBDOS=""
QUIT
Begin DoDot:2
+10 SET IBINS=""
FOR
SET IBINS=$ORDER(^TMP("IBFBWL",$JOB,IBDOS,IBINS))
if IBINS=""
QUIT
Begin DoDot:3
+11 IF $DATA(^TMP("IBFBWL",$JOB,IBDOS,IBINS,IBNAME,DFN,IBAUTH))
Begin DoDot:4
+12 KILL ^TMP("IBFBWL",$JOB,IBDOS,IBINS,IBNAME,DFN,IBAUTH)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
RURRC ; Reason Codes
+1 ; Option 2 (internal comment 2) was removed - Addl Info Req - Refer to FR - and renumbered
+2 DO SET^VALM10(6,"","")
+3 DO SET^VALM10(7," At the second prompt, you may enter one of the following:","")
+4 DO SET^VALM10(8,"","")
+5 DO SET^VALM10(9," 1. Pending Payer Action 6. Continued Stay Review","")
+6 DO SET^VALM10(10," 2. Auth Not Reqd - SC/SA 7. Discharge Review Required","")
+7 DO SET^VALM10(11," 3. Auth Not Reqd - Payer Contacted 8. Partial SC Stay - Auth Worked","")
+8 DO SET^VALM10(12," 4. Auth Not Required 9. Partial Stay/Visit Approved","")
+9 DO SET^VALM10(13," 5. Auth Obtained 10. Auth Denied","")
+10 DO SET^VALM10(14," 11. Auth Not Obtained/No ROI/Sent to FR","")
+11 QUIT
+12 ;
RURRCPR ; RUR Reason Code Prompt
+1 NEW X,Y
+2 SET IBRC=""
+3 KILL DIR
SET DIR(0)="NO^1:11"
+4 SET DIR("A")="Enter REASON CODE (1-11) or return: "
+5 SET DIR("?",1)="Enter a Reason Code between 1 and 11 or Enter if no code."
+6 DO ^DIR
KILL DIR
+7 SET IBRC=$GET(Y)
+8 IF IBRC="^"
WRITE !,"This response must be a number."
GOTO RURRCPR
+9 SET IBRC=$SELECT(IBRC=1:1,IBRC=2:3,IBRC=3:4,IBRC=4:5,IBRC=5:6,IBRC=6:7,IBRC=7:8,IBRC=8:9,IBRC=9:10,IBRC=10:11,IBRC=11:12,1:"")
+10 QUIT
+11 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO ^%ZISC
+2 SET VALMBCK="R"
+3 QUIT
