Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBTRC

IBTRC.m

Go to the documentation of this file. 
  1. IBTRC	;ALB/AAS - CLAIMS TRACKING INSURANCE REVIEWS ; 27-JUN-1993
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. %	;
  1. EN	; -- main entry point for IBT COMMUNICATIONS EDITOR from menu's
  1. 	I '$D(DT) D DT^DICRW
  1. 	K XQORS,VALMEVL,IBTRN,IBTRND,IBCNT,DFN,IBTRC,IBTRV,IBTRD,IBCNS,IBCDFN,IBFASTXT,VALMQUIT,VA,VAIN,VAERR
  1. 	;I '$D(IBTRN) D EN^IBTRE Q
  1. 	D PAT^IBCNSM I $D(VALMQUIT) G ENQ
  1. 	D TRAC^IBTRV I $D(VALMQUIT) G ENQ
  1. 	I '$G(IBTRPRF) S IBTRPRF="12"
  1. 	D EN^VALM("IBT COMMUNICATIONS EDITOR")
  1. ENQ	K XQORS,VALMEVL,IBTRN,IBTRND,IBCNT,DFN,IBTRC,IBTRV,IBTRD,IBCNS,IBCDFN,IBFASTXT,VALMQUIT,IBTRPRF,VA,VAIN,VAERR,X,Y,I,J,IBETYP
  1. 	K IBAMT,IBAPR,IBADG,IBDA,IBDGCR,IBDGCRU1,IBDV,IBETYP,IBETYPD,IBI,IBICD,IBLCNT,IBSEL,IBT,IBTEXT,IBTNOD,IBTSAV,VAUTD
  1. 	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
  1. 	D KVAR^VADPT
  1. 	Q
  1. 	;
  1. HDR	; -- header code
  1. 	D PID^VADPT
  1. 	S VALMHDR(1)="Insurance Review Entries for: "_$$PT^IBTUTL1(DFN)_"   ROI: "_$$EXPAND^IBTRE(356,.31,$P(^IBT(356,IBTRN,0),"^",31))
  1. 	S VALMHDR(2)="                         for: "_$$EXPAND^IBTRE(356,.18,$P(IBTRND,"^",18))_" on "_$$DAT1^IBOUTL($P(IBTRND,"^",6),"2P")
  1. 	Q
  1. 	;
  1. INIT	; -- init variables and list array
  1. 	S U="^",VALMCNT=0,VALMBG=1
  1. 	K ^TMP("IBTRC",$J),^TMP("IBTRCDX",$J)
  1. 	K I,X,XQORNOD,DA,DR,DIE,DNM,DQ
  1. 	S IBTRND=$G(^IBT(356,IBTRN,0))
  1. 	D BLD
  1. 	Q
  1. 	;
  1. BLD	; -- Build list of Insurnace contacts
  1. 	K ^TMP("IBTRC",$J),^TMP("IBTRCDX",$J)
  1. 	N IBI,J,IBTRC,IBTRCD,IBTRCD1
  1. 	S VALMSG=$$MSG^IBTUTL3(DFN)
  1. 	S (IBTRC,IBCNT,VALMCNT)=0,IBI=""
  1. 	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
  1. 	.S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
  1. 	.S IBTRCD1=$G(^IBT(356.2,+IBTRC,1))
  1. 	.Q:'+$P(IBTRCD,"^",19)  ;quit if inactive
  1. 	.S IBCNT=IBCNT+1
  1. 	.S IBETYP=$G(^IBE(356.11,+$P(IBTRCD,"^",4),0))
  1. 	.W "."
  1. 	.S X=""
  1. 	.S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
  1. 	.S X=$$SETFLD^VALM1($P($$DAT1^IBOUTL(+IBTRCD,"2P")," "),X,"DATE")
  1. 	.S X=$$SETFLD^VALM1($P($G(^DIC(36,+$P(IBTRCD,"^",8),0)),"^"),X,"INS CO")
  1. 	.S X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11)),X,"ACTION")
  1. 	.;
  1. 	.S X=$$SETFLD^VALM1($P(IBETYP,"^",3),X,"TYPE")
  1. 	.S X=$$SETFLD^VALM1($P(IBTRCD,"^",28),X,"PRE-CERT")
  1. 	.I $P(IBTRCD,"^",13) S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",12),$P(IBTRCD,"^",13),IBTRN),3),X,"DAYS")
  1. 	.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")
  1. 	.I $P(IBTRCD1,"^",7)!($P(IBTRCD1,"^",8)) S X=$$SETFLD^VALM1("ALL",X,"DAYS")
  1. 	.S X=$$SETFLD^VALM1($P(IBTRCD,"^",6),X,"CONTACT")
  1. 	.S X=$$SETFLD^VALM1($P(IBTRCD,"^",7),X,"PHONE")
  1. 	.S X=$$SETFLD^VALM1($P(IBTRCD,"^",9),X,"REF NO")
  1. 	.I $P(IBETYP,"^",2)=60!($P(IBETYP,"^",2)=65) D APPEAL^IBTRC3
  1. 	.D SET(X)
  1. 	Q
  1. 	;
  1. SET(X)	; -- set arrays
  1. 	S VALMCNT=VALMCNT+1
  1. 	S ^TMP("IBTRC",$J,VALMCNT,0)=X
  1. 	S ^TMP("IBTRC",$J,"IDX",VALMCNT,IBCNT)=""
  1. 	S ^TMP("IBTRCDX",$J,IBCNT)=VALMCNT_"^"_IBTRC
  1. 	Q
  1. HELP	; -- help code
  1. 	S X="?" D DISP^XQORM1 W !!
  1. 	Q
  1. 	;
  1. EXIT	; -- exit code
  1. 	K ^TMP("IBTRC",$J),^TMP("IBTRCDX",$J)
  1. 	K IBTRC
  1. 	D CLEAN^VALM10
  1. 	Q
  1. 	;
  1. TYPE(IBTRC)	; -- compute default type of contact
  1. 	N TYPE,IBTRTP,IBTRN,IBSCHED
  1. 	S TYPE=""
  1. 	I '$P($G(^IBT(356.2,IBTRC,0)),"^",2) S TYPE=70 G TYPEQ ;no tracking id default is patient
  1. 	S IBTRN=$P($G(^IBT(356.2,IBTRC,0)),"^",2),IBTRTP=$$TRTP^IBTRE1(IBTRN)
  1. 	;
  1. 	; -- if from a review
  1. 	I $G(IBTRV) S TYPE=$$TRTP^IBTRV(IBTRV) G TYPEQ ; if from review use review type
  1. 	I IBTRTP>1 S TYPE=50 G TYPEQ ; outpatient
  1. 	S IBSCHED=$S($P($G(^DGPM(+$P($G(^IBT(356,IBTRN,0)),U,5),0)),U,25):10,1:20)
  1. 	I '$O(^IBT(356.2,"ATRTP",IBTRN,0)) S TYPE=IBSCHED G TYPEQ ; default for first is urgent admission
  1. 	S TYPE=30 ; default is continued stay
  1. 	;
  1. TYPEQ	Q $P($G(^IBE(356.11,+$O(^IBE(356.11,"ACODE",+TYPE,0)),0)),"^")
  1. 	;
  1. TCODE(IBTRC)	; -- return type code for entry
  1. 	Q $P($G(^IBE(356.11,+$P($G(^IBT(356.2,+$G(IBTRC),0)),"^",4),0)),"^",2)
  1. 	;
  1. CONTCT(DA,Y)	; -- screen for type of contact
  1. 	; -- called by dic(s) on lookup of type of contact field in 356.2
  1. 	;
  1. 	;"I ($P(^(0),U,2)>60&('$P(^IBT(356.2,DA,0),U,2)))!($P(^(0),U,2))"
  1. 	N IBOK,TCODE S IBOK=1
  1. 	S TCODE=$P(^(0),U,2)
  1. 	I TCODE=85 S IBOK=0 G CONTQ ;insurance verification from ins menu only
  1. 	I TCODE=15 S IBOK=0 G CONTQ ;Admission review only for hosp reviews
  1. 	I '$P($G(^IBT(356.2,DA,0)),U,2),TCODE<70 S IBOK=0 G CONTQ ;no tracking id, only patient or other
  1. 	I TCODE=60,'$P($G(^IBT(356.2,DA,0)),U,18) S IBOK=0 G CONTQ ;appeals must have an associated parent denial
  1. 	S IBTRTP=$$TRTP^IBTRE1($P($G(^IBT(356.2,DA,0)),U,2))
  1. 	I IBTRTP>1,TCODE<50 S IBOK=0 ; not inpatient care, not inpt codes
  1. CONTQ	Q IBOK