IBTRC ;ALB/AAS - CLAIMS TRACKING INSURANCE REVIEWS ; 27-JUN-1993
;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4
;;Per VHA Directive 2004-038, this routine should not be modified.
;
% ;
EN ; -- main entry point for IBT COMMUNICATIONS EDITOR from menu's
I '$D(DT) D DT^DICRW
K XQORS,VALMEVL,IBTRN,IBTRND,IBCNT,DFN,IBTRC,IBTRV,IBTRD,IBCNS,IBCDFN,IBFASTXT,VALMQUIT,VA,VAIN,VAERR
;I '$D(IBTRN) D EN^IBTRE Q
D PAT^IBCNSM I $D(VALMQUIT) G ENQ
D TRAC^IBTRV I $D(VALMQUIT) G ENQ
I '$G(IBTRPRF) S IBTRPRF="12"
D EN^VALM("IBT COMMUNICATIONS EDITOR")
ENQ K XQORS,VALMEVL,IBTRN,IBTRND,IBCNT,DFN,IBTRC,IBTRV,IBTRD,IBCNS,IBCDFN,IBFASTXT,VALMQUIT,IBTRPRF,VA,VAIN,VAERR,X,Y,I,J,IBETYP
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
D PID^VADPT N IBXR
S VALMHDR(1)="Insurance Review Entries for: "_$$PT^IBTUTL1(DFN)
S IBXR=$$ROIEVT^IBTRR1(IBTRN) I IBXR'="" S VALMHDR(1)=VALMHDR(1)_$J(" ",(60-$L(VALMHDR(1))))_"ROI: "_IBXR
S VALMHDR(2)=" for: "_$$EXPAND^IBTRE(356,.18,$P(IBTRND,"^",18))_" on "_$$DAT1^IBOUTL($P(IBTRND,"^",6),"2P")
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
S IBTRND=$G(^IBT(356,IBTRN,0))
D BLD
Q
;
BLD ; -- Build list of Insurnace contacts
K ^TMP("IBTRC",$J),^TMP("IBTRCDX",$J)
N IBI,J,IBTRC,IBTRCD,IBTRCD1
S VALMSG=$$MSG^IBTUTL3(DFN)
S (IBTRC,IBCNT,VALMCNT)=0,IBI=""
F S IBI=$O(^IBT(356.2,"ATIDT",IBTRN,IBI)) Q:'IBI S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"ATIDT",IBTRN,IBI,IBTRC)) Q:'IBTRC D
.S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
.S IBTRCD1=$G(^IBT(356.2,+IBTRC,1))
.Q:'+$P(IBTRCD,"^",19) ;quit if inactive
.S IBCNT=IBCNT+1
.S IBETYP=$G(^IBE(356.11,+$P(IBTRCD,"^",4),0))
.W "."
.S X=""
.S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
.S X=$$SETFLD^VALM1($P($$DAT1^IBOUTL(+IBTRCD,"2P")," "),X,"DATE")
.S X=$$SETFLD^VALM1($P($G(^DIC(36,+$P(IBTRCD,"^",8),0)),"^"),X,"INS CO")
.S X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11)),X,"ACTION")
.;
.S X=$$SETFLD^VALM1($P(IBETYP,"^",3),X,"TYPE")
.S X=$$SETFLD^VALM1($$AUTHN(IBTRC,10),X,"PRE-CERT")
.I $P(IBTRCD,"^",13) S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",12),$P(IBTRCD,"^",13),IBTRN),3),X,"DAYS")
.I $P($G(^IBE(356.7,+$P(IBTRCD,"^",11),0)),"^",3)=20 S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",15),$P(IBTRCD,"^",16),IBTRN),3),X,"DAYS")
.I $P(IBTRCD1,"^",7)!($P(IBTRCD1,"^",8)) S X=$$SETFLD^VALM1("ALL",X,"DAYS")
.S X=$$SETFLD^VALM1($P(IBTRCD,"^",6),X,"CONTACT")
.S X=$$SETFLD^VALM1($P(IBTRCD,"^",7),X,"PHONE")
.S X=$$SETFLD^VALM1($$CREFN(IBTRC,12),X,"REF NO")
.I $P(IBETYP,"^",2)=60!($P(IBETYP,"^",2)=65) D APPEAL^IBTRC3
.D SET(X)
Q
;
SET(X) ; -- set arrays
S VALMCNT=VALMCNT+1
S ^TMP("IBTRC",$J,VALMCNT,0)=X
S ^TMP("IBTRC",$J,"IDX",VALMCNT,IBCNT)=""
S ^TMP("IBTRCDX",$J,IBCNT)=VALMCNT_"^"_IBTRC
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBTRC",$J),^TMP("IBTRCDX",$J)
K IBTRC
D CLEAN^VALM10
Q
;
AUTHN(IBTRC,LNG) ; -- return autorization number (356.2, 2.02) - length and append *
N X S X=$P($G(^IBT(356.2,+$G(IBTRC),2)),"^",2) I +$G(LNG),$L(X)>LNG S X=$E(X,1,(LNG-1))_"*"
Q X
;
CREFN(IBTRC,LNG) ; -- return call reference number (356.2, 2.01) - length and append *
N X S X=$P($G(^IBT(356.2,+$G(IBTRC),2)),"^",1) I +$G(LNG),$L(X)>LNG S X=$E(X,1,(LNG-1))_"*"
Q X
;
;
TYPE(IBTRC) ; -- compute default type of contact
N TYPE,IBTRTP,IBTRN,IBSCHED
S TYPE=""
I '$P($G(^IBT(356.2,IBTRC,0)),"^",2) S TYPE=70 G TYPEQ ;no tracking id default is patient
S IBTRN=$P($G(^IBT(356.2,IBTRC,0)),"^",2),IBTRTP=$$TRTP^IBTRE1(IBTRN)
;
; -- if from a review
I $G(IBTRV) S TYPE=$$TRTP^IBTRV(IBTRV) G TYPEQ ; if from review use review type
I IBTRTP>1 S TYPE=50 G TYPEQ ; outpatient
S IBSCHED=$S($P($G(^DGPM(+$P($G(^IBT(356,IBTRN,0)),U,5),0)),U,25):10,1:20)
I '$O(^IBT(356.2,"ATRTP",IBTRN,0)) S TYPE=IBSCHED G TYPEQ ; default for first is urgent admission
S TYPE=30 ; default is continued stay
;
TYPEQ Q $P($G(^IBE(356.11,+$O(^IBE(356.11,"ACODE",+TYPE,0)),0)),"^")
;
TCODE(IBTRC) ; -- return type code for entry
Q $P($G(^IBE(356.11,+$P($G(^IBT(356.2,+$G(IBTRC),0)),"^",4),0)),"^",2)
;
CONTCT(DA,Y) ; -- screen for type of contact
; -- called by dic(s) on lookup of type of contact field in 356.2
;
;"I ($P(^(0),U,2)>60&('$P(^IBT(356.2,DA,0),U,2)))!($P(^(0),U,2))"
N IBOK,TCODE S IBOK=1
S TCODE=$P(^(0),U,2)
I TCODE=85 S IBOK=0 G CONTQ ;insurance verification from ins menu only
I TCODE=15 S IBOK=0 G CONTQ ;Admission review only for hosp reviews
I '$P($G(^IBT(356.2,DA,0)),U,2),TCODE<70 S IBOK=0 G CONTQ ;no tracking id, only patient or other
I TCODE=60,'$P($G(^IBT(356.2,DA,0)),U,18) S IBOK=0 G CONTQ ;appeals must have an associated parent denial
S IBTRTP=$$TRTP^IBTRE1($P($G(^IBT(356.2,DA,0)),U,2))
I IBTRTP>1,TCODE<50 S IBOK=0 ; not inpatient care, not inpt codes
CONTQ Q IBOK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRC 5265 printed Dec 13, 2024@02:27:33 Page 2
IBTRC ;ALB/AAS - CLAIMS TRACKING INSURANCE REVIEWS ; 27-JUN-1993
+1 ;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
% ;
EN ; -- main entry point for IBT COMMUNICATIONS EDITOR from menu's
+1 IF '$DATA(DT)
DO DT^DICRW
+2 KILL XQORS,VALMEVL,IBTRN,IBTRND,IBCNT,DFN,IBTRC,IBTRV,IBTRD,IBCNS,IBCDFN,IBFASTXT,VALMQUIT,VA,VAIN,VAERR
+3 ;I '$D(IBTRN) D EN^IBTRE Q
+4 DO PAT^IBCNSM
IF $DATA(VALMQUIT)
GOTO ENQ
+5 DO TRAC^IBTRV
IF $DATA(VALMQUIT)
GOTO ENQ
+6 IF '$GET(IBTRPRF)
SET IBTRPRF="12"
+7 DO EN^VALM("IBT COMMUNICATIONS EDITOR")
ENQ KILL XQORS,VALMEVL,IBTRN,IBTRND,IBCNT,DFN,IBTRC,IBTRV,IBTRD,IBCNS,IBCDFN,IBFASTXT,VALMQUIT,IBTRPRF,VA,VAIN,VAERR,X,Y,I,J,IBETYP
+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 DO PID^VADPT
NEW IBXR
+2 SET VALMHDR(1)="Insurance Review Entries for: "_$$PT^IBTUTL1(DFN)
+3 SET IBXR=$$ROIEVT^IBTRR1(IBTRN)
IF IBXR'=""
SET VALMHDR(1)=VALMHDR(1)_$JUSTIFY(" ",(60-$LENGTH(VALMHDR(1))))_"ROI: "_IBXR
+4 SET VALMHDR(2)=" for: "_$$EXPAND^IBTRE(356,.18,$PIECE(IBTRND,"^",18))_" on "_$$DAT1^IBOUTL($PIECE(IBTRND,"^",6),"2P")
+5 QUIT
+6 ;
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
+4 SET IBTRND=$GET(^IBT(356,IBTRN,0))
+5 DO BLD
+6 QUIT
+7 ;
BLD ; -- Build list of Insurnace contacts
+1 KILL ^TMP("IBTRC",$JOB),^TMP("IBTRCDX",$JOB)
+2 NEW IBI,J,IBTRC,IBTRCD,IBTRCD1
+3 SET VALMSG=$$MSG^IBTUTL3(DFN)
+4 SET (IBTRC,IBCNT,VALMCNT)=0
SET IBI=""
+5 FOR
SET IBI=$ORDER(^IBT(356.2,"ATIDT",IBTRN,IBI))
if 'IBI
QUIT
SET IBTRC=0
FOR
SET IBTRC=$ORDER(^IBT(356.2,"ATIDT",IBTRN,IBI,IBTRC))
if 'IBTRC
QUIT
Begin DoDot:1
+6 SET IBTRCD=$GET(^IBT(356.2,+IBTRC,0))
+7 SET IBTRCD1=$GET(^IBT(356.2,+IBTRC,1))
+8 ;quit if inactive
if '+$PIECE(IBTRCD,"^",19)
QUIT
+9 SET IBCNT=IBCNT+1
+10 SET IBETYP=$GET(^IBE(356.11,+$PIECE(IBTRCD,"^",4),0))
+11 WRITE "."
+12 SET X=""
+13 SET X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
+14 SET X=$$SETFLD^VALM1($PIECE($$DAT1^IBOUTL(+IBTRCD,"2P")," "),X,"DATE")
+15 SET X=$$SETFLD^VALM1($PIECE($GET(^DIC(36,+$PIECE(IBTRCD,"^",8),0)),"^"),X,"INS CO")
+16 SET X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.11,$PIECE(IBTRCD,"^",11)),X,"ACTION")
+17 ;
+18 SET X=$$SETFLD^VALM1($PIECE(IBETYP,"^",3),X,"TYPE")
+19 SET X=$$SETFLD^VALM1($$AUTHN(IBTRC,10),X,"PRE-CERT")
+20 IF $PIECE(IBTRCD,"^",13)
SET X=$$SETFLD^VALM1($JUSTIFY($$DAY^IBTUTL3($PIECE(IBTRCD,"^",12),$PIECE(IBTRCD,"^",13),IBTRN),3),X,"DAYS")
+21 IF $PIECE($GET(^IBE(356.7,+$PIECE(IBTRCD,"^",11),0)),"^",3)=20
SET X=$$SETFLD^VALM1($JUSTIFY($$DAY^IBTUTL3($PIECE(IBTRCD,"^",15),$PIECE(IBTRCD,"^",16),IBTRN),3),X,"DAYS")
+22 IF $PIECE(IBTRCD1,"^",7)!($PIECE(IBTRCD1,"^",8))
SET X=$$SETFLD^VALM1("ALL",X,"DAYS")
+23 SET X=$$SETFLD^VALM1($PIECE(IBTRCD,"^",6),X,"CONTACT")
+24 SET X=$$SETFLD^VALM1($PIECE(IBTRCD,"^",7),X,"PHONE")
+25 SET X=$$SETFLD^VALM1($$CREFN(IBTRC,12),X,"REF NO")
+26 IF $PIECE(IBETYP,"^",2)=60!($PIECE(IBETYP,"^",2)=65)
DO APPEAL^IBTRC3
+27 DO SET(X)
End DoDot:1
+28 QUIT
+29 ;
SET(X) ; -- set arrays
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBTRC",$JOB,VALMCNT,0)=X
+3 SET ^TMP("IBTRC",$JOB,"IDX",VALMCNT,IBCNT)=""
+4 SET ^TMP("IBTRCDX",$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("IBTRC",$JOB),^TMP("IBTRCDX",$JOB)
+2 KILL IBTRC
+3 DO CLEAN^VALM10
+4 QUIT
+5 ;
AUTHN(IBTRC,LNG) ; -- return autorization number (356.2, 2.02) - length and append *
+1 NEW X
SET X=$PIECE($GET(^IBT(356.2,+$GET(IBTRC),2)),"^",2)
IF +$GET(LNG)
IF $LENGTH(X)>LNG
SET X=$EXTRACT(X,1,(LNG-1))_"*"
+2 QUIT X
+3 ;
CREFN(IBTRC,LNG) ; -- return call reference number (356.2, 2.01) - length and append *
+1 NEW X
SET X=$PIECE($GET(^IBT(356.2,+$GET(IBTRC),2)),"^",1)
IF +$GET(LNG)
IF $LENGTH(X)>LNG
SET X=$EXTRACT(X,1,(LNG-1))_"*"
+2 QUIT X
+3 ;
+4 ;
TYPE(IBTRC) ; -- compute default type of contact
+1 NEW TYPE,IBTRTP,IBTRN,IBSCHED
+2 SET TYPE=""
+3 ;no tracking id default is patient
IF '$PIECE($GET(^IBT(356.2,IBTRC,0)),"^",2)
SET TYPE=70
GOTO TYPEQ
+4 SET IBTRN=$PIECE($GET(^IBT(356.2,IBTRC,0)),"^",2)
SET IBTRTP=$$TRTP^IBTRE1(IBTRN)
+5 ;
+6 ; -- if from a review
+7 ; if from review use review type
IF $GET(IBTRV)
SET TYPE=$$TRTP^IBTRV(IBTRV)
GOTO TYPEQ
+8 ; outpatient
IF IBTRTP>1
SET TYPE=50
GOTO TYPEQ
+9 SET IBSCHED=$SELECT($PIECE($GET(^DGPM(+$PIECE($GET(^IBT(356,IBTRN,0)),U,5),0)),U,25):10,1:20)
+10 ; default for first is urgent admission
IF '$ORDER(^IBT(356.2,"ATRTP",IBTRN,0))
SET TYPE=IBSCHED
GOTO TYPEQ
+11 ; default is continued stay
SET TYPE=30
+12 ;
TYPEQ QUIT $PIECE($GET(^IBE(356.11,+$ORDER(^IBE(356.11,"ACODE",+TYPE,0)),0)),"^")
+1 ;
TCODE(IBTRC) ; -- return type code for entry
+1 QUIT $PIECE($GET(^IBE(356.11,+$PIECE($GET(^IBT(356.2,+$GET(IBTRC),0)),"^",4),0)),"^",2)
+2 ;
CONTCT(DA,Y) ; -- screen for type of contact
+1 ; -- called by dic(s) on lookup of type of contact field in 356.2
+2 ;
+3 ;"I ($P(^(0),U,2)>60&('$P(^IBT(356.2,DA,0),U,2)))!($P(^(0),U,2))"
+4 NEW IBOK,TCODE
SET IBOK=1
+5 SET TCODE=$PIECE(^(0),U,2)
+6 ;insurance verification from ins menu only
IF TCODE=85
SET IBOK=0
GOTO CONTQ
+7 ;Admission review only for hosp reviews
IF TCODE=15
SET IBOK=0
GOTO CONTQ
+8 ;no tracking id, only patient or other
IF '$PIECE($GET(^IBT(356.2,DA,0)),U,2)
IF TCODE<70
SET IBOK=0
GOTO CONTQ
+9 ;appeals must have an associated parent denial
IF TCODE=60
IF '$PIECE($GET(^IBT(356.2,DA,0)),U,18)
SET IBOK=0
GOTO CONTQ
+10 SET IBTRTP=$$TRTP^IBTRE1($PIECE($GET(^IBT(356.2,DA,0)),U,2))
+11 ; not inpatient care, not inpt codes
IF IBTRTP>1
IF TCODE<50
SET IBOK=0
CONTQ QUIT IBOK
