IBFBWL5 ;ALB/PAW-IB NVC Precert Worklist Main ;30-SEP-2015
;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
;Per VA Directive 6402, this routine should not be modified.
;
GETAUT(IBGRP) ; Obtain new authorizations, based upon review group
;required input IBGRP = 1 (IV) or 2 (RUR)
;output ^TMP("IBFBWL",$J), containing auths for group queue
N IBA
S IBA=""
I IBGRP=1 D LOOP1
I IBGRP=2 D LOOP2
Q
;
LOOP1 ; Loop to create Insurance Verification Worklist
N IBDEL
F S IBA=$O(^IBFB(360,"IV","IV",IBA)) Q:IBA="" D
. S IBDEL=$$GET1^DIQ(360,IBA_",",.04)
. I IBDEL'="" Q ; Check for deleted auth
. D BLDTMP
Q
;
LOOP2 ; Loop to create RUR Worklist
N FDA,IBDEL,IBNRD,IENROOT
F S IBA=$O(^IBFB(360,"UR","UR",IBA)) Q:IBA="" D
. S IBNRD=$$GET1^DIQ(360,IBA_",",3.01,"I")
. S IBDEL=$$GET1^DIQ(360,IBA_",",.04)
. I IBDEL'="" Q ; Check for deleted auth
. I IBNRD>DT Q ; RUR Next Review Date in future
. I IBNRD'<DT D
.. S IENROOT=""
.. S FDA(360,IBA_",",3.01)=""
.. D UPDATE^DIE("","FDA","IENROOT")
. D BLDTMP
Q
;
BLDTMP ; Build ^TMP("IBFBWL",$J)
N DFN,IBAUTH,IBCHO,IBCON,IBDIV,IBDOB,IBFBINS,IBIEN,IBNAME,IBSSN,IBFP,IBST,IBEND
S IBCHO=""
I '$D(^IBFB(360,IBA)) Q
S DFN=$$GET1^DIQ(360,IBA_",",.02,"I")
S IBAUTH=$$GET1^DIQ(360,IBA_",",.03)
S IBIEN=IBAUTH_","_DFN_","
S IBST=$$GET1^DIQ(161.01,IBIEN_",",.01,"I")
S IBFBINS=$$INSURED^IBCNS1(DFN,IBST) ; Check for active insurance as of auth state date
Q:'IBFBINS ; If no active insurance, do not display on worklist
S IBDIV=$$GET1^DIQ(161.01,IBIEN_",",101,"I")
I IBDIV'="",$D(FILTERS(1)) I '$D(FILTERS(1,IBDIV)) Q ; If filtering by select divisions
I IBDIV="",$D(FILTERS(1)) Q ; Filtering by division, but no division on auth
I $D(FILTERS(2)) I '$D(FILTERS(2,DFN)) Q ; If filtering by select patients
S IBCON=$$GET1^DIQ(161.01,IBIEN_",",105,"I") ; Get contract number
I IBCON S IBCHO=$$GET1^DIQ(161.43,IBCON_",",4) ; Check CHOICE Program Indicator on contract
I IBCHO="YES" Q ; Bypass auths with CHOICE contracts
D DEMOS
Q
;
DEMOS ; Auth Demographics
N IBEND,IBFP,IBINDT,IBSSN,IBINS0,IBINSCO,IBINS,IBSSX,IBSSLE,IBSSLS,VA,VAERR,VADM
D DEM^VADPT
I VAERR K VADM
S IBNAME=$G(VADM(1)) S:IBNAME="" IBNAME=" "
S IBSSX=$P($G(VADM(2)),U,1),IBSSLE=$L(IBSSX),IBSSLS=6 I $E(IBSSX,IBSSLE)="P" S IBSSLS=5
S IBSSN=$E(IBNAME,1)_$E(IBSSX,IBSSLS,IBSSLE)
S IBFP=$$GET1^DIQ(161.01,IBIEN_",",.03)
S IBEND=$$GET1^DIQ(161.01,IBIEN_",",.02,"I")
S IBINDT=IBST
I IBST="" S IBINDT=DT
D ALL^IBCNS1(DFN,"IBINS",1,IBINDT,1) ; Sort in COB order - Need highest / PRIMARY
S IBINS0=$O(IBINS(0))
S IBINS0=IBINS(IBINS0,0)
I IBINS0'="" S IBINSCO=$$GET1^DIQ(36,+IBINS0_",",.01)
I $G(IBINSCO)="" S IBINSCO="UNKNOWN"
I IBINS0="" S IBINS0=99999999
; The next two lines sort for IV (IBGRP=1) or RUR (IBGRP=2)
; IV sort is by primary insurance
; RUR sort is by auth start date, then primary insurance
I IBGRP=1 S ^TMP("IBFBWL",$J,IBINSCO,IBNAME,DFN,IBAUTH)=IBNAME_U_IBSSN_U_IBFP_U_IBINSCO_U_IBST_U_IBEND
I IBGRP=2 S ^TMP("IBFBWL",$J,IBST,IBINSCO,IBNAME,DFN,IBAUTH)=IBNAME_U_IBSSN_U_IBFP_U_IBINSCO_U_IBST_U_IBEND
Q
;
BLDWL ; Build Work List Screen
; Build display lines
; Loop by IV (IBGRP=1) or RUR (IBGRP=2) sort
K ^TMP("IBFBWLX",$J)
N DFN,IBAUTH,IBINS0,IBNAME,IBXX,FIRST,LINE,VCNT,IBST
S (VALMCNT,FIRST,VCNT)=0
I IBGRP=1 D Q
. S IBINS0=""
. F S IBINS0=$O(^TMP("IBFBWL",$J,IBINS0)) Q:IBINS0="" D
.. S IBNAME=""
.. F S IBNAME=$O(^TMP("IBFBWL",$J,IBINS0,IBNAME)) Q:IBNAME="" D
... S FIRST=1
... S DFN=""
... F S DFN=$O(^TMP("IBFBWL",$J,IBINS0,IBNAME,DFN)) Q:DFN="" D
.... S IBAUTH=""
.... F S IBAUTH=$O(^TMP("IBFBWL",$J,IBINS0,IBNAME,DFN,IBAUTH)) Q:IBAUTH="" D
..... S VCNT=VCNT+1
..... S LINE=$$SETL("",VCNT,"",1,4) ;line#
..... S IBXX=^TMP("IBFBWL",$J,IBINS0,IBNAME,DFN,IBAUTH)
..... D SETX
I IBGRP=2 D Q
. S IBST=""
. F S IBST=$O(^TMP("IBFBWL",$J,IBST)) Q:IBST="" D
.. S IBINS0=""
.. F S IBINS0=$O(^TMP("IBFBWL",$J,IBST,IBINS0)) Q:IBINS0="" D
... S IBNAME=""
... F S IBNAME=$O(^TMP("IBFBWL",$J,IBST,IBINS0,IBNAME)) Q:IBNAME="" D
.... S FIRST=1
.... S DFN=""
.... F S DFN=$O(^TMP("IBFBWL",$J,IBST,IBINS0,IBNAME,DFN)) Q:DFN="" D
..... S IBAUTH=""
..... F S IBAUTH=$O(^TMP("IBFBWL",$J,IBST,IBINS0,IBNAME,DFN,IBAUTH)) Q:IBAUTH="" D
...... S VCNT=VCNT+1
...... S LINE=$$SETL("",VCNT,"",1,4) ;line#
...... S IBXX=^TMP("IBFBWL",$J,IBST,IBINS0,IBNAME,DFN,IBAUTH)
...... D SETX
Q
;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
; of the worklist
; Input: LINE - Current line being created
; DATA - Information to be added to the end of the current line
; LABEL - Label to describe the information being added
; COL - Column position in line to add information add
; LNG - Maximum length of data information to include on the line
; Returns: Line updated with added information
S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG)
Q LINE
;
SETX ; Set temp global IBFBWLX by VCNT
S IBNAME=$P(IBXX,U)
S LINE=$$SETL(LINE,IBNAME,"",5,23)
S LINE=$$SETL(LINE,$P(IBXX,U,2),"",29,5)
S LINE=$$SETL(LINE,$P(IBXX,U,3),"",35,10)
S LINE=$$SETL(LINE,$P(IBXX,U,4),"",46,15)
I $P(IBXX,U,5)'="" S LINE=$$SETL(LINE,$$FDATE^VALM1($P(IBXX,U,5)),"",62,8)
I $P(IBXX,U,6)'="" S LINE=$$SETL(LINE,$$FDATE^VALM1($P(IBXX,U,6)),"",71,8)
S VALMCNT=VALMCNT+1
D SET^VALM10(VALMCNT,LINE,VCNT)
S ^TMP("IBFBWLX",$J,VCNT)=DFN_U_IBNAME_U_IBAUTH
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBFBWL5 5537 printed Oct 16, 2024@18:23:06 Page 2
IBFBWL5 ;ALB/PAW-IB NVC Precert Worklist Main ;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 ;
GETAUT(IBGRP) ; Obtain new authorizations, based upon review group
+1 ;required input IBGRP = 1 (IV) or 2 (RUR)
+2 ;output ^TMP("IBFBWL",$J), containing auths for group queue
+3 NEW IBA
+4 SET IBA=""
+5 IF IBGRP=1
DO LOOP1
+6 IF IBGRP=2
DO LOOP2
+7 QUIT
+8 ;
LOOP1 ; Loop to create Insurance Verification Worklist
+1 NEW IBDEL
+2 FOR
SET IBA=$ORDER(^IBFB(360,"IV","IV",IBA))
if IBA=""
QUIT
Begin DoDot:1
+3 SET IBDEL=$$GET1^DIQ(360,IBA_",",.04)
+4 ; Check for deleted auth
IF IBDEL'=""
QUIT
+5 DO BLDTMP
End DoDot:1
+6 QUIT
+7 ;
LOOP2 ; Loop to create RUR Worklist
+1 NEW FDA,IBDEL,IBNRD,IENROOT
+2 FOR
SET IBA=$ORDER(^IBFB(360,"UR","UR",IBA))
if IBA=""
QUIT
Begin DoDot:1
+3 SET IBNRD=$$GET1^DIQ(360,IBA_",",3.01,"I")
+4 SET IBDEL=$$GET1^DIQ(360,IBA_",",.04)
+5 ; Check for deleted auth
IF IBDEL'=""
QUIT
+6 ; RUR Next Review Date in future
IF IBNRD>DT
QUIT
+7 IF IBNRD'<DT
Begin DoDot:2
+8 SET IENROOT=""
+9 SET FDA(360,IBA_",",3.01)=""
+10 DO UPDATE^DIE("","FDA","IENROOT")
End DoDot:2
+11 DO BLDTMP
End DoDot:1
+12 QUIT
+13 ;
BLDTMP ; Build ^TMP("IBFBWL",$J)
+1 NEW DFN,IBAUTH,IBCHO,IBCON,IBDIV,IBDOB,IBFBINS,IBIEN,IBNAME,IBSSN,IBFP,IBST,IBEND
+2 SET IBCHO=""
+3 IF '$DATA(^IBFB(360,IBA))
QUIT
+4 SET DFN=$$GET1^DIQ(360,IBA_",",.02,"I")
+5 SET IBAUTH=$$GET1^DIQ(360,IBA_",",.03)
+6 SET IBIEN=IBAUTH_","_DFN_","
+7 SET IBST=$$GET1^DIQ(161.01,IBIEN_",",.01,"I")
+8 ; Check for active insurance as of auth state date
SET IBFBINS=$$INSURED^IBCNS1(DFN,IBST)
+9 ; If no active insurance, do not display on worklist
if 'IBFBINS
QUIT
+10 SET IBDIV=$$GET1^DIQ(161.01,IBIEN_",",101,"I")
+11 ; If filtering by select divisions
IF IBDIV'=""
IF $DATA(FILTERS(1))
IF '$DATA(FILTERS(1,IBDIV))
QUIT
+12 ; Filtering by division, but no division on auth
IF IBDIV=""
IF $DATA(FILTERS(1))
QUIT
+13 ; If filtering by select patients
IF $DATA(FILTERS(2))
IF '$DATA(FILTERS(2,DFN))
QUIT
+14 ; Get contract number
SET IBCON=$$GET1^DIQ(161.01,IBIEN_",",105,"I")
+15 ; Check CHOICE Program Indicator on contract
IF IBCON
SET IBCHO=$$GET1^DIQ(161.43,IBCON_",",4)
+16 ; Bypass auths with CHOICE contracts
IF IBCHO="YES"
QUIT
+17 DO DEMOS
+18 QUIT
+19 ;
DEMOS ; Auth Demographics
+1 NEW IBEND,IBFP,IBINDT,IBSSN,IBINS0,IBINSCO,IBINS,IBSSX,IBSSLE,IBSSLS,VA,VAERR,VADM
+2 DO DEM^VADPT
+3 IF VAERR
KILL VADM
+4 SET IBNAME=$GET(VADM(1))
if IBNAME=""
SET IBNAME=" "
+5 SET IBSSX=$PIECE($GET(VADM(2)),U,1)
SET IBSSLE=$LENGTH(IBSSX)
SET IBSSLS=6
IF $EXTRACT(IBSSX,IBSSLE)="P"
SET IBSSLS=5
+6 SET IBSSN=$EXTRACT(IBNAME,1)_$EXTRACT(IBSSX,IBSSLS,IBSSLE)
+7 SET IBFP=$$GET1^DIQ(161.01,IBIEN_",",.03)
+8 SET IBEND=$$GET1^DIQ(161.01,IBIEN_",",.02,"I")
+9 SET IBINDT=IBST
+10 IF IBST=""
SET IBINDT=DT
+11 ; Sort in COB order - Need highest / PRIMARY
DO ALL^IBCNS1(DFN,"IBINS",1,IBINDT,1)
+12 SET IBINS0=$ORDER(IBINS(0))
+13 SET IBINS0=IBINS(IBINS0,0)
+14 IF IBINS0'=""
SET IBINSCO=$$GET1^DIQ(36,+IBINS0_",",.01)
+15 IF $GET(IBINSCO)=""
SET IBINSCO="UNKNOWN"
+16 IF IBINS0=""
SET IBINS0=99999999
+17 ; The next two lines sort for IV (IBGRP=1) or RUR (IBGRP=2)
+18 ; IV sort is by primary insurance
+19 ; RUR sort is by auth start date, then primary insurance
+20 IF IBGRP=1
SET ^TMP("IBFBWL",$JOB,IBINSCO,IBNAME,DFN,IBAUTH)=IBNAME_U_IBSSN_U_IBFP_U_IBINSCO_U_IBST_U_IBEND
+21 IF IBGRP=2
SET ^TMP("IBFBWL",$JOB,IBST,IBINSCO,IBNAME,DFN,IBAUTH)=IBNAME_U_IBSSN_U_IBFP_U_IBINSCO_U_IBST_U_IBEND
+22 QUIT
+23 ;
BLDWL ; Build Work List Screen
+1 ; Build display lines
+2 ; Loop by IV (IBGRP=1) or RUR (IBGRP=2) sort
+3 KILL ^TMP("IBFBWLX",$JOB)
+4 NEW DFN,IBAUTH,IBINS0,IBNAME,IBXX,FIRST,LINE,VCNT,IBST
+5 SET (VALMCNT,FIRST,VCNT)=0
+6 IF IBGRP=1
Begin DoDot:1
+7 SET IBINS0=""
+8 FOR
SET IBINS0=$ORDER(^TMP("IBFBWL",$JOB,IBINS0))
if IBINS0=""
QUIT
Begin DoDot:2
+9 SET IBNAME=""
+10 FOR
SET IBNAME=$ORDER(^TMP("IBFBWL",$JOB,IBINS0,IBNAME))
if IBNAME=""
QUIT
Begin DoDot:3
+11 SET FIRST=1
+12 SET DFN=""
+13 FOR
SET DFN=$ORDER(^TMP("IBFBWL",$JOB,IBINS0,IBNAME,DFN))
if DFN=""
QUIT
Begin DoDot:4
+14 SET IBAUTH=""
+15 FOR
SET IBAUTH=$ORDER(^TMP("IBFBWL",$JOB,IBINS0,IBNAME,DFN,IBAUTH))
if IBAUTH=""
QUIT
Begin DoDot:5
+16 SET VCNT=VCNT+1
+17 ;line#
SET LINE=$$SETL("",VCNT,"",1,4)
+18 SET IBXX=^TMP("IBFBWL",$JOB,IBINS0,IBNAME,DFN,IBAUTH)
+19 DO SETX
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+20 IF IBGRP=2
Begin DoDot:1
+21 SET IBST=""
+22 FOR
SET IBST=$ORDER(^TMP("IBFBWL",$JOB,IBST))
if IBST=""
QUIT
Begin DoDot:2
+23 SET IBINS0=""
+24 FOR
SET IBINS0=$ORDER(^TMP("IBFBWL",$JOB,IBST,IBINS0))
if IBINS0=""
QUIT
Begin DoDot:3
+25 SET IBNAME=""
+26 FOR
SET IBNAME=$ORDER(^TMP("IBFBWL",$JOB,IBST,IBINS0,IBNAME))
if IBNAME=""
QUIT
Begin DoDot:4
+27 SET FIRST=1
+28 SET DFN=""
+29 FOR
SET DFN=$ORDER(^TMP("IBFBWL",$JOB,IBST,IBINS0,IBNAME,DFN))
if DFN=""
QUIT
Begin DoDot:5
+30 SET IBAUTH=""
+31 FOR
SET IBAUTH=$ORDER(^TMP("IBFBWL",$JOB,IBST,IBINS0,IBNAME,DFN,IBAUTH))
if IBAUTH=""
QUIT
Begin DoDot:6
+32 SET VCNT=VCNT+1
+33 ;line#
SET LINE=$$SETL("",VCNT,"",1,4)
+34 SET IBXX=^TMP("IBFBWL",$JOB,IBST,IBINS0,IBNAME,DFN,IBAUTH)
+35 DO SETX
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+36 QUIT
+37 ;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
+1 ; of the worklist
+2 ; Input: LINE - Current line being created
+3 ; DATA - Information to be added to the end of the current line
+4 ; LABEL - Label to describe the information being added
+5 ; COL - Column position in line to add information add
+6 ; LNG - Maximum length of data information to include on the line
+7 ; Returns: Line updated with added information
+8 SET LINE=LINE_$JUSTIFY("",(COL-$LENGTH(LABEL)-$LENGTH(LINE)))_LABEL_$EXTRACT(DATA,1,LNG)
+9 QUIT LINE
+10 ;
SETX ; Set temp global IBFBWLX by VCNT
+1 SET IBNAME=$PIECE(IBXX,U)
+2 SET LINE=$$SETL(LINE,IBNAME,"",5,23)
+3 SET LINE=$$SETL(LINE,$PIECE(IBXX,U,2),"",29,5)
+4 SET LINE=$$SETL(LINE,$PIECE(IBXX,U,3),"",35,10)
+5 SET LINE=$$SETL(LINE,$PIECE(IBXX,U,4),"",46,15)
+6 IF $PIECE(IBXX,U,5)'=""
SET LINE=$$SETL(LINE,$$FDATE^VALM1($PIECE(IBXX,U,5)),"",62,8)
+7 IF $PIECE(IBXX,U,6)'=""
SET LINE=$$SETL(LINE,$$FDATE^VALM1($PIECE(IBXX,U,6)),"",71,8)
+8 SET VALMCNT=VALMCNT+1
+9 DO SET^VALM10(VALMCNT,LINE,VCNT)
+10 SET ^TMP("IBFBWLX",$JOB,VCNT)=DFN_U_IBNAME_U_IBAUTH
+11 QUIT
