- 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 Feb 18, 2025@23:48:52 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