IBTRD ;ALB/AAS - CLAIMS TRACKING - DENIAL/ APPEALS ; 10-AUG-1993
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% ;
EN ; -- main entry point for IBT APPEAL/DENAIL EDITOR
I '$D(DT) D DT^DICRW
K XQORS,VALMEVL,IBTRD,DFN,IBCNS,IBTRN,IBTRV,IBTRC,IBFASTXT,VALMQUIT
D ASK
G:$D(VALMQUIT) ENQ
I IBTRD["DPT(" S IBTYPE="P",DFN=+IBTRD D EN^VALM("IBT APPEAL/DENIAL EDITOR")
I IBTRD["DIC(" S IBTYPE="I",IBCNS=+IBTRD D EN^VALM("IBT APPEAL/DENIAL INS EDITOR")
ENQ K XQORS,VALMEVL,IBTRD,DFN,IBCNS,IBTRN,IBTRV,IBTRC,IBFASTXT,VALMQUIT
K IBAMT,IBAPR,IBADG,IBDA,IBDGCR,IBDGCRU1,IBDV,IBETYP,IBETYPD,IBI,IBICD,IBLCNT,IBSEL,IBT,IBTEXT,IBTNOD,IBTSAV,VAUTD
K IBAPEAL,IBCDFN,IBCNT,IBDEN,IBDENIAL,IBDENIAL,IBPARNT,IBPEN,IBPENAL,IBTCOD,IBTRDD,IBTRSV,IBTYPE,VAINDT,VA,VALMBCK,OFFSET,I1,I3,IBNEW,IBDENT,IBOE,Z1,T,SDCNT
D KVAR^VADPT
Q
;
HDR ; -- header code
I $G(IBTYPE)="P" D HDRP
I $G(IBTYPE)="I" D HDRI
Q
;
HDRI ; -- header code for by ins. co.
S VALMHDR(1)="Denials and Appeals for: "_$P(^DIC(36,+IBCNS,0),"^")
S VALMHDR(2)=" "
Q
;
HDRP ; -- header code for by pat.
D PID^VADPT
S VALMHDR(1)="Denials and Appeals for: "_$$PT^IBTUTL1(DFN)
S VALMHDR(2)=" "
Q
;
INIT ; -- init variables and list array
S U="^",VALMCNT=0,VALMBG=1
K ^TMP("IBTRC",$J),^TMP("IBTRCDX",$J)
K I,X,XQORNOD,DA,DR,DIE,DNM,DQ,IBTRC
I '$G(IBTRD),$G(DFN) S IBTRD=DFN_";DPT("
I '$G(IBTRD) S VALMQUIT=""
S IBTRSV=""
Q:$D(VALMQUIT)
;
BLD ; -- build list
K ^TMP("IBTRD",$J),^TMP("IBTRDDX",$J)
N IBI,J,IBTRC,IBTRCD,IBTRCD1,IBTRN
I IBTRD["DPT(" S IBTYPE="P",DFN=+IBTRD D BLDP
I IBTRD["DIC(" S IBTYPE="I",IBCNS=+IBTRD D BLDI
Q
;
BLDI ; -- Build list of appeals/denials by ins. co.
D HDRI
S (IBTRC,IBCNT,VALMCNT)=0
S IBDEN=$O(^IBE(356.7,"ACODE",20,0))
S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"AIACT",IBCNS,IBDEN,IBTRC)) Q:'IBTRC D 1
S IBPEN=$O(^IBE(356.7,"ACODE",30,0))
S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"AIACT",IBCNS,IBPEN,IBTRC)) Q:'IBTRC D 1
Q
;
BLDP ; -- Build list of appeals/denials by patient
D HDRP
S (IBTRC,IBCNT,VALMCNT)=0
S VALMSG=$$MSG^IBTUTL3(DFN)
S IBDEN=$O(^IBE(356.7,"ACODE",20,0))
S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"APACT",DFN,IBDEN,IBTRC)) Q:'IBTRC D 1
S IBPEN=$O(^IBE(356.7,"ACODE",30,0))
S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"APACT",DFN,IBPEN,IBTRC)) Q:'IBTRC D 1
Q
1 ; -- first add denial, then add appeal
S IBTRN=$P(^IBT(356.2,+IBTRC,0),"^",2)
S IBTRSV=+IBTRC
D 2
N IBTRC,IBTRCD,IBTRCD1
S IBAPEAL=$O(^IBE(356.11,"ACODE",60,0)) ; find appeals
S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"AP",IBTRSV,IBTRC)) Q:'IBTRC D 2
;
Q
2 ; -- add items to list
S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
S IBTRCD1=$G(^IBT(356.2,+IBTRC,1))
Q:'+$P(IBTRCD,"^",19) ;quit if inactive
;
; -- if not the denial, must be from parent
I IBTRC'=IBTRSV&($P(IBTRCD,"^",18)'=IBTRSV) Q
;
S IBCNT=IBCNT+1
W "."
I IBTYPE="I" S DFN=$P(IBTRCD,"^",5) D PID^VADPT
S X=""
S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
;
I IBTYPE="I" D
.S X=$$SETFLD^VALM1($P(^DPT(DFN,0),"^"),X,"PATIENT")
.S X=$$SETFLD^VALM1(VA("BID"),X,"ID")
;
I IBTYPE="P" D
.S X=$$SETFLD^VALM1($P($G(^DIC(36,+$P(IBTRCD,"^",8),0)),"^"),X,"INS CO")
.S X=$$SETFLD^VALM1($$GRP^IBCNS(+$P($G(^DPT(DFN,.312,+$P(IBTRCD1,"^",5),0)),"^",18)),X,"POLICY")
;
S X=$$SETFLD^VALM1($P($$DAT1^IBOUTL(+IBTRCD,"2P")," "),X,"DATE")
I $P(IBTRCD,"^",11) S X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11)),X,"ACTION")
I $P(IBTRCD,"^",11)="" S X=$$SETFLD^VALM1($P($G(^IBE(356.11,+$P(IBTRCD,"^",4),0)),"^",3),X,"ACTION")
;
S X=$$SETFLD^VALM1($P($G(^IBE(356.6,+$P(^IBT(356,+IBTRN,0),"^",18),0)),"^",2),X,"EVENT")
S X=$$SETFLD^VALM1($$DAT1^IBOUTL(+$P(^IBT(356,+IBTRN,0),"^",6),"2P"),X,"EV DATE")
S X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.04,$P(IBTRCD,"^",4)),X,"TYPE")
S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",15),$P(IBTRCD,"^",16),IBTRN),3),X,"DAYS")
S X=$$SETFLD^VALM1($$EXPAND^IBTRE(356,.31,$P(^IBT(356,IBTRN,0),"^",31)),X,"ROI")
S X=$$SETFLD^VALM1($P(IBTRCD,"^",6),X,"CONTACT")
S X=$$SETFLD^VALM1($P(IBTRCD,"^",7),X,"PHONE")
S X=$$SETFLD^VALM1($P(IBTRCD,"^",9),X,"REF NO")
D SET(X)
Q
;
SET(X) ; -- set arrays
S VALMCNT=VALMCNT+1
S ^TMP("IBTRD",$J,VALMCNT,0)=X
S ^TMP("IBTRD",$J,"IDX",VALMCNT,IBCNT)=""
S ^TMP("IBTRDDX",$J,IBCNT)=VALMCNT_"^"_IBTRC
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBTRD",$J),^TMP("IBTRDDX",$J)
D CLEAN^VALM10
Q
;
ASK ; -- ask for patient or ins. co.
N DIR
S DIR(0)="350.9,4.02",DIR("A")="Select Patient Name or Insurance Co."
D ^DIR K DIR I $D(DIRUT) S VALMQUIT="" G ASKQ
S IBTRD=Y
I +IBTRD<1 S VALMQUIT=""
ASKQ Q
IBTRD ;ALB/AAS - CLAIMS TRACKING - DENIAL/ APPEALS ; 10-AUG-1993
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% ;
EN ; -- main entry point for IBT APPEAL/DENAIL EDITOR
+1 IF '$DATA(DT)
DO DT^DICRW
+2 KILL XQORS,VALMEVL,IBTRD,DFN,IBCNS,IBTRN,IBTRV,IBTRC,IBFASTXT,VALMQUIT
+3 DO ASK
+4 IF $DATA(VALMQUIT)
GOTO ENQ
+5 IF IBTRD["DPT("
SET IBTYPE="P"
SET DFN=+IBTRD
DO EN^VALM("IBT APPEAL/DENIAL EDITOR")
+6 IF IBTRD["DIC("
SET IBTYPE="I"
SET IBCNS=+IBTRD
DO EN^VALM("IBT APPEAL/DENIAL INS EDITOR")
ENQ KILL XQORS,VALMEVL,IBTRD,DFN,IBCNS,IBTRN,IBTRV,IBTRC,IBFASTXT,VALMQUIT
+1 KILL IBAMT,IBAPR,IBADG,IBDA,IBDGCR,IBDGCRU1,IBDV,IBETYP,IBETYPD,IBI,IBICD,IBLCNT,IBSEL,IBT,IBTEXT,IBTNOD,IBTSAV,VAUTD
+2 KILL IBAPEAL,IBCDFN,IBCNT,IBDEN,IBDENIAL,IBDENIAL,IBPARNT,IBPEN,IBPENAL,IBTCOD,IBTRDD,IBTRSV,IBTYPE,VAINDT,VA,VALMBCK,OFFSET,I1,I3,IBNEW,IBDENT,IBOE,Z1,T,SDCNT
+3 DO KVAR^VADPT
+4 QUIT
+5 ;
HDR ; -- header code
+1 IF $GET(IBTYPE)="P"
DO HDRP
+2 IF $GET(IBTYPE)="I"
DO HDRI
+3 QUIT
+4 ;
HDRI ; -- header code for by ins. co.
+1 SET VALMHDR(1)="Denials and Appeals for: "_$PIECE(^DIC(36,+IBCNS,0),"^")
+2 SET VALMHDR(2)=" "
+3 QUIT
+4 ;
HDRP ; -- header code for by pat.
+1 DO PID^VADPT
+2 SET VALMHDR(1)="Denials and Appeals for: "_$$PT^IBTUTL1(DFN)
+3 SET VALMHDR(2)=" "
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 SET U="^"
SET VALMCNT=0
SET VALMBG=1
+2 KILL ^TMP("IBTRC",$JOB),^TMP("IBTRCDX",$JOB)
+3 KILL I,X,XQORNOD,DA,DR,DIE,DNM,DQ,IBTRC
+4 IF '$GET(IBTRD)
IF $GET(DFN)
SET IBTRD=DFN_";DPT("
+5 IF '$GET(IBTRD)
SET VALMQUIT=""
+6 SET IBTRSV=""
+7 IF $DATA(VALMQUIT)
QUIT
+8 ;
BLD ; -- build list
+1 KILL ^TMP("IBTRD",$JOB),^TMP("IBTRDDX",$JOB)
+2 NEW IBI,J,IBTRC,IBTRCD,IBTRCD1,IBTRN
+3 IF IBTRD["DPT("
SET IBTYPE="P"
SET DFN=+IBTRD
DO BLDP
+4 IF IBTRD["DIC("
SET IBTYPE="I"
SET IBCNS=+IBTRD
DO BLDI
+5 QUIT
+6 ;
BLDI ; -- Build list of appeals/denials by ins. co.
+1 DO HDRI
+2 SET (IBTRC,IBCNT,VALMCNT)=0
+3 SET IBDEN=$ORDER(^IBE(356.7,"ACODE",20,0))
+4 SET IBTRC=0
FOR
SET IBTRC=$ORDER(^IBT(356.2,"AIACT",IBCNS,IBDEN,IBTRC))
IF 'IBTRC
QUIT
DO 1
+5 SET IBPEN=$ORDER(^IBE(356.7,"ACODE",30,0))
+6 SET IBTRC=0
FOR
SET IBTRC=$ORDER(^IBT(356.2,"AIACT",IBCNS,IBPEN,IBTRC))
IF 'IBTRC
QUIT
DO 1
+7 QUIT
+8 ;
BLDP ; -- Build list of appeals/denials by patient
+1 DO HDRP
+2 SET (IBTRC,IBCNT,VALMCNT)=0
+3 SET VALMSG=$$MSG^IBTUTL3(DFN)
+4 SET IBDEN=$ORDER(^IBE(356.7,"ACODE",20,0))
+5 SET IBTRC=0
FOR
SET IBTRC=$ORDER(^IBT(356.2,"APACT",DFN,IBDEN,IBTRC))
IF 'IBTRC
QUIT
DO 1
+6 SET IBPEN=$ORDER(^IBE(356.7,"ACODE",30,0))
+7 SET IBTRC=0
FOR
SET IBTRC=$ORDER(^IBT(356.2,"APACT",DFN,IBPEN,IBTRC))
IF 'IBTRC
QUIT
DO 1
+8 QUIT
1 ; -- first add denial, then add appeal
+1 SET IBTRN=$PIECE(^IBT(356.2,+IBTRC,0),"^",2)
+2 SET IBTRSV=+IBTRC
+3 DO 2
+4 NEW IBTRC,IBTRCD,IBTRCD1
+5 ; find appeals
SET IBAPEAL=$ORDER(^IBE(356.11,"ACODE",60,0))
+6 SET IBTRC=0
FOR
SET IBTRC=$ORDER(^IBT(356.2,"AP",IBTRSV,IBTRC))
IF 'IBTRC
QUIT
DO 2
+7 ;
+8 QUIT
2 ; -- add items to list
+1 SET IBTRCD=$GET(^IBT(356.2,+IBTRC,0))
+2 SET IBTRCD1=$GET(^IBT(356.2,+IBTRC,1))
+3 ;quit if inactive
IF '+$PIECE(IBTRCD,"^",19)
QUIT
+4 ;
+5 ; -- if not the denial, must be from parent
+6 IF IBTRC'=IBTRSV&($PIECE(IBTRCD,"^",18)'=IBTRSV)
QUIT
+7 ;
+8 SET IBCNT=IBCNT+1
+9 WRITE "."
+10 IF IBTYPE="I"
SET DFN=$PIECE(IBTRCD,"^",5)
DO PID^VADPT
+11 SET X=""
+12 SET X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
+13 ;
+14 IF IBTYPE="I"
Begin DoDot:1
+15 SET X=$$SETFLD^VALM1($PIECE(^DPT(DFN,0),"^"),X,"PATIENT")
+16 SET X=$$SETFLD^VALM1(VA("BID"),X,"ID")
End DoDot:1
+17 ;
+18 IF IBTYPE="P"
Begin DoDot:1
+19 SET X=$$SETFLD^VALM1($PIECE($GET(^DIC(36,+$PIECE(IBTRCD,"^",8),0)),"^"),X,"INS CO")
+20 SET X=$$SETFLD^VALM1($$GRP^IBCNS(+$PIECE($GET(^DPT(DFN,.312,+$PIECE(IBTRCD1,"^",5),0)),"^",18)),X,"POLICY")
End DoDot:1
+21 ;
+22 SET X=$$SETFLD^VALM1($PIECE($$DAT1^IBOUTL(+IBTRCD,"2P")," "),X,"DATE")
+23 IF $PIECE(IBTRCD,"^",11)
SET X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.11,$PIECE(IBTRCD,"^",11)),X,"ACTION")
+24 IF $PIECE(IBTRCD,"^",11)=""
SET X=$$SETFLD^VALM1($PIECE($GET(^IBE(356.11,+$PIECE(IBTRCD,"^",4),0)),"^",3),X,"ACTION")
+25 ;
+26 SET X=$$SETFLD^VALM1($PIECE($GET(^IBE(356.6,+$PIECE(^IBT(356,+IBTRN,0),"^",18),0)),"^",2),X,"EVENT")
+27 SET X=$$SETFLD^VALM1($$DAT1^IBOUTL(+$PIECE(^IBT(356,+IBTRN,0),"^",6),"2P"),X,"EV DATE")
+28 SET X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.04,$PIECE(IBTRCD,"^",4)),X,"TYPE")
+29 SET X=$$SETFLD^VALM1($JUSTIFY($$DAY^IBTUTL3($PIECE(IBTRCD,"^",15),$PIECE(IBTRCD,"^",16),IBTRN),3),X,"DAYS")
+30 SET X=$$SETFLD^VALM1($$EXPAND^IBTRE(356,.31,$PIECE(^IBT(356,IBTRN,0),"^",31)),X,"ROI")
+31 SET X=$$SETFLD^VALM1($PIECE(IBTRCD,"^",6),X,"CONTACT")
+32 SET X=$$SETFLD^VALM1($PIECE(IBTRCD,"^",7),X,"PHONE")
+33 SET X=$$SETFLD^VALM1($PIECE(IBTRCD,"^",9),X,"REF NO")
+34 DO SET(X)
+35 QUIT
+36 ;
SET(X) ; -- set arrays
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBTRD",$JOB,VALMCNT,0)=X
+3 SET ^TMP("IBTRD",$JOB,"IDX",VALMCNT,IBCNT)=""
+4 SET ^TMP("IBTRDDX",$JOB,IBCNT)=VALMCNT_"^"_IBTRC
+5 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBTRD",$JOB),^TMP("IBTRDDX",$JOB)
+2 DO CLEAN^VALM10
+3 QUIT
+4 ;
ASK ; -- ask for patient or ins. co.
+1 NEW DIR
+2 SET DIR(0)="350.9,4.02"
SET DIR("A")="Select Patient Name or Insurance Co."
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET VALMQUIT=""
GOTO ASKQ
+4 SET IBTRD=Y
+5 IF +IBTRD<1
SET VALMQUIT=""
ASKQ QUIT
