IBJTEA ;ALB/ARH-TPI PATIENT ELIGIBLITY SCREEN ;16-FEB-1995
;;2.0;INTEGRATED BILLING;**39,153,183**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; the EL Patient Eligibility screen is based on the Eligibility Inquiry for Patient Billing
; [DG PATIENT ELIGIBILITY INQUIRY] display option
;
EN ; -- main entry point for IBJ TP CLAIMS INFO
D EN^VALM("IBJT PT ELIGIBILITY")
Q
;
HDR ; -- header code
D HDR^IBJTU1(+$G(IBIFN),+DFN,1)
Q
;
INIT ; -- init variables and list array
K ^TMP("IBJTEA",$J)
I '$G(DFN) S VALMQUIT="" G INITQ
I '$G(IBIFN) D PRTCL^IBJU1("IBJT SHORT MENU")
D BLD
INITQ Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBJTEA",$J)
D CLEAR^VALM1
Q
;
BLD ; DFN, required, uses Statment From date of the bill if available, DT if not
I '$G(DFN) G BLDQ
N IBX,IBY,IBI,IBDU,IBDT,IBDTE,IBLN,IBD,IBT,IBTC,IBTW,IBSW,IBLR,IBGRPB,IBGRPE,IBCNT
S (IBLN,VALMCNT)=1
S IBTC(1)=1,IBTW(1)=25,IBSW(1)=23,IBTC(2)=52,IBTW(2)=15,IBSW(2)=11,IBTC(4)=1,IBTW(4)=0,IBSW(4)=38
;
S IBGRPB=IBLN,IBLR=1
;
S IBX=$$LST^DGMTU(DFN)
S IBT="Means Test: ",IBD=$P(IBX,U,4)
S IBD=$S('IBX:"Not in Means Test File",IBD="P":"PEN",IBD="C":"YES",IBD="G":"GMT",IBD="R":"REQ",1:"NO")
S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Date of Test: ",IBD=$$DATE^IBJU1($P(IBX,U,2)) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBX=$$LST^DGMTU(DFN,"",2)
S IBT="Co-pay Exemption Test: ",IBD=$P(IBX,U,3) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Date of Test: ",IBD=$$DATE^IBJU1($P(IBX,U,2)) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;
I +$$BIL^DGMTUB(DFN) S IBT="",IBD="Patient has agreed to pay deductible" S IBLN=$$SET(IBT,IBD,IBLN,4)
;
S IBGRPE=IBLN,IBLN=IBGRPB,IBLR=2
;
S IBT="Insured: ",IBD=$S(+$$INSURED^IBCNS1(DFN):"Yes",1:"No") S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
D SVC^VADPT
S IBT="A/O Exposure: ",IBD=$S(+VASV(2):"Yes",1:"") S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Rad. Exposure: ",IBD=$S(+VASV(3):"Yes",1:"") S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
K VASV
;
S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE)
S IBTC(5)=1,IBTW(5)=25,IBSW(5)=53,IBLR=5
S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;
D ELIG^VADPT
S IBT="Primary Elig. Code: ",IBD=$P(VAEL(1),U,2)_$S(VAEL(8)'="":" -- "_$P(VAEL(8),U,2),1:"") S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I $D(VAEL(1))>1 S IBT="Other Elig. Code(s): ",IBI=0 F S IBI=$O(VAEL(1,IBI)) Q:'IBI D
. S IBD=$P(VAEL(1,IBI),U,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;
S IBT="Service Connected: ",IBD=$S('VAEL(3):"No",1:$P(VAEL(3),U,2)_"%") S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Rated Disabilities: " D
. I 'VAEL(4) S IBD="Not a Veteran" S IBLN=$$SET(IBT,IBD,IBLN,IBLR) Q
. I '$O(^DPT(DFN,.372,0)) S IBD="None" S IBLN=$$SET(IBT,IBD,IBLN,IBLR) Q
. S IBI=0 F S IBI=$O(^DPT(DFN,.372,IBI)) Q:'IBI D
.. S IBX=$G(^DPT(DFN,.372,IBI,0)),IBY=$G(^DIC(31,+IBX,0))
.. S IBD=$S($P(IBY,U,4)="":$P(IBY,U,1),1:$P(IBY,U,4))_" ("_$P(IBX,U,2)_"%-"_$S(+$P(IBX,U,3):"SC",1:"NSC")_")"
.. S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
K VAEL
;
; initially requested by a test site, but group decided only rated disablities should be displayed
;I $O(^DPT(DFN,.373,0)) D
;. ;
;. S IBTC(1)=0,IBTW(1)=0,IBSW(1)=79,IBLR=1
;. S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;. ;
;. S IBT="",IBD=" Service Connected Conditions as stated by applicant" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;. S IBT="",IBD=" ---------------------------------------------------" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;. ;
;. S (IBT,IBD)="",(IBCNT,IBI)=0
;. F S IBI=$O(^DPT(DFN,.373,IBI)) Q:'IBI D
;.. S IBX=$G(^DPT(DFN,.373,IBI,0)) Q:IBX=""
;.. S IBY=$P(IBX,U,1)_" ("_$P(IBX,U,2)_"%)"
;.. S IBD=IBD_" "_IBY_$J("",(37-$L(IBY))),IBCNT=IBCNT+1
;.. I IBCNT>1 S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBD="",IBCNT=0
;. I IBD'="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBD="",IBCNT=0
;
S VALMCNT=IBLN-1
;
BLDQ K VAERR
Q
;
SET(TTL,DATA,LN,LR) ;
N IBY
S IBY=$J(TTL,IBTW(LR))_DATA D SET1(IBY,LN,IBTC(LR),(IBTW(LR)+IBSW(LR)))
S LN=LN+1
Q LN
;
SET1(STR,LN,COL,WD,RV) ; set up TMP array with screen data
N IBX S IBX=$G(^TMP("IBJTEA",$J,LN,0))
S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
D SET^VALM10(LN,IBX) I $G(RV)'="" D CNTRL^VALM10(LN,COL,WD,IORVON,IORVOFF)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTEA 4347 printed Apr 09, 2024@21:23:22 Page 2
IBJTEA ;ALB/ARH-TPI PATIENT ELIGIBLITY SCREEN ;16-FEB-1995
+1 ;;2.0;INTEGRATED BILLING;**39,153,183**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; the EL Patient Eligibility screen is based on the Eligibility Inquiry for Patient Billing
+5 ; [DG PATIENT ELIGIBILITY INQUIRY] display option
+6 ;
EN ; -- main entry point for IBJ TP CLAIMS INFO
+1 DO EN^VALM("IBJT PT ELIGIBILITY")
+2 QUIT
+3 ;
HDR ; -- header code
+1 DO HDR^IBJTU1(+$GET(IBIFN),+DFN,1)
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("IBJTEA",$JOB)
+2 IF '$GET(DFN)
SET VALMQUIT=""
GOTO INITQ
+3 IF '$GET(IBIFN)
DO PRTCL^IBJU1("IBJT SHORT MENU")
+4 DO BLD
INITQ QUIT
+1 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBJTEA",$JOB)
+2 DO CLEAR^VALM1
+3 QUIT
+4 ;
BLD ; DFN, required, uses Statment From date of the bill if available, DT if not
+1 IF '$GET(DFN)
GOTO BLDQ
+2 NEW IBX,IBY,IBI,IBDU,IBDT,IBDTE,IBLN,IBD,IBT,IBTC,IBTW,IBSW,IBLR,IBGRPB,IBGRPE,IBCNT
+3 SET (IBLN,VALMCNT)=1
+4 SET IBTC(1)=1
SET IBTW(1)=25
SET IBSW(1)=23
SET IBTC(2)=52
SET IBTW(2)=15
SET IBSW(2)=11
SET IBTC(4)=1
SET IBTW(4)=0
SET IBSW(4)=38
+5 ;
+6 SET IBGRPB=IBLN
SET IBLR=1
+7 ;
+8 SET IBX=$$LST^DGMTU(DFN)
+9 SET IBT="Means Test: "
SET IBD=$PIECE(IBX,U,4)
+10 SET IBD=$SELECT('IBX:"Not in Means Test File",IBD="P":"PEN",IBD="C":"YES",IBD="G":"GMT",IBD="R":"REQ",1:"NO")
+11 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+12 SET IBT="Date of Test: "
SET IBD=$$DATE^IBJU1($PIECE(IBX,U,2))
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+13 SET IBX=$$LST^DGMTU(DFN,"",2)
+14 SET IBT="Co-pay Exemption Test: "
SET IBD=$PIECE(IBX,U,3)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+15 SET IBT="Date of Test: "
SET IBD=$$DATE^IBJU1($PIECE(IBX,U,2))
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+16 ;
+17 IF +$$BIL^DGMTUB(DFN)
SET IBT=""
SET IBD="Patient has agreed to pay deductible"
SET IBLN=$$SET(IBT,IBD,IBLN,4)
+18 ;
+19 SET IBGRPE=IBLN
SET IBLN=IBGRPB
SET IBLR=2
+20 ;
+21 SET IBT="Insured: "
SET IBD=$SELECT(+$$INSURED^IBCNS1(DFN):"Yes",1:"No")
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+22 DO SVC^VADPT
+23 SET IBT="A/O Exposure: "
SET IBD=$SELECT(+VASV(2):"Yes",1:"")
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+24 SET IBT="Rad. Exposure: "
SET IBD=$SELECT(+VASV(3):"Yes",1:"")
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+25 KILL VASV
+26 ;
+27 SET (IBLN,VALMCNT)=$SELECT(IBLN>IBGRPE:IBLN,1:IBGRPE)
+28 SET IBTC(5)=1
SET IBTW(5)=25
SET IBSW(5)=53
SET IBLR=5
+29 SET (IBT,IBD)=""
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+30 ;
+31 DO ELIG^VADPT
+32 SET IBT="Primary Elig. Code: "
SET IBD=$PIECE(VAEL(1),U,2)_$SELECT(VAEL(8)'="":" -- "_$PIECE(VAEL(8),U,2),1:"")
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+33 IF $DATA(VAEL(1))>1
SET IBT="Other Elig. Code(s): "
SET IBI=0
FOR
SET IBI=$ORDER(VAEL(1,IBI))
if 'IBI
QUIT
Begin DoDot:1
+34 SET IBD=$PIECE(VAEL(1,IBI),U,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
SET IBT=""
End DoDot:1
+35 SET (IBT,IBD)=""
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+36 ;
+37 SET IBT="Service Connected: "
SET IBD=$SELECT('VAEL(3):"No",1:$PIECE(VAEL(3),U,2)_"%")
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+38 SET IBT="Rated Disabilities: "
Begin DoDot:1
+39 IF 'VAEL(4)
SET IBD="Not a Veteran"
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
QUIT
+40 IF '$ORDER(^DPT(DFN,.372,0))
SET IBD="None"
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
QUIT
+41 SET IBI=0
FOR
SET IBI=$ORDER(^DPT(DFN,.372,IBI))
if 'IBI
QUIT
Begin DoDot:2
+42 SET IBX=$GET(^DPT(DFN,.372,IBI,0))
SET IBY=$GET(^DIC(31,+IBX,0))
+43 SET IBD=$SELECT($PIECE(IBY,U,4)="":$PIECE(IBY,U,1),1:$PIECE(IBY,U,4))_" ("_$PIECE(IBX,U,2)_"%-"_$SELECT(+$PIECE(IBX,U,3):"SC",1:"NSC")_")"
+44 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
SET IBT=""
End DoDot:2
End DoDot:1
+45 KILL VAEL
+46 ;
+47 ; initially requested by a test site, but group decided only rated disablities should be displayed
+48 ;I $O(^DPT(DFN,.373,0)) D
+49 ;. ;
+50 ;. S IBTC(1)=0,IBTW(1)=0,IBSW(1)=79,IBLR=1
+51 ;. S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+52 ;. ;
+53 ;. S IBT="",IBD=" Service Connected Conditions as stated by applicant" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+54 ;. S IBT="",IBD=" ---------------------------------------------------" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+55 ;. ;
+56 ;. S (IBT,IBD)="",(IBCNT,IBI)=0
+57 ;. F S IBI=$O(^DPT(DFN,.373,IBI)) Q:'IBI D
+58 ;.. S IBX=$G(^DPT(DFN,.373,IBI,0)) Q:IBX=""
+59 ;.. S IBY=$P(IBX,U,1)_" ("_$P(IBX,U,2)_"%)"
+60 ;.. S IBD=IBD_" "_IBY_$J("",(37-$L(IBY))),IBCNT=IBCNT+1
+61 ;.. I IBCNT>1 S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBD="",IBCNT=0
+62 ;. I IBD'="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBD="",IBCNT=0
+63 ;
+64 SET VALMCNT=IBLN-1
+65 ;
BLDQ KILL VAERR
+1 QUIT
+2 ;
SET(TTL,DATA,LN,LR) ;
+1 NEW IBY
+2 SET IBY=$JUSTIFY(TTL,IBTW(LR))_DATA
DO SET1(IBY,LN,IBTC(LR),(IBTW(LR)+IBSW(LR)))
+3 SET LN=LN+1
+4 QUIT LN
+5 ;
SET1(STR,LN,COL,WD,RV) ; set up TMP array with screen data
+1 NEW IBX
SET IBX=$GET(^TMP("IBJTEA",$JOB,LN,0))
+2 SET IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
+3 DO SET^VALM10(LN,IBX)
IF $GET(RV)'=""
DO CNTRL^VALM10(LN,COL,WD,IORVON,IORVOFF)
+4 QUIT
