- 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 Jan 18, 2025@03:25:04 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