IBCNES ;ALB/ESG - eIV elig/Benefit screen ; 14-Jul-2009
;;2.0;INTEGRATED BILLING;**416,438,497,506,702**;21-MAR-94;Build 53
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
EB(IBVF,IBVIENS,IBVEBFLG,IBVV,IBVSUB) ; entry point for main list display
; see below at tag INIT for a description of the parameters
; IBVSUB is required at this entry point because the ListMan array uses this variable
;
D EN^VALM("IBCNE ELIGIBILITY/BENEFIT INFO")
EBX ;
Q
;
HDR ; -- header code - called by ListManager
; build the header area based on the values of IBVF and IBVIENS
;
; pt. insurance
I IBVF=2.322 D
. N DFN,IBCDFN,PNB,PN,LPID,INS,INSNM,IENS,RSDATE,RSTYPE
. S DFN=+$P(IBVIENS,",",2)
. S IBCDFN=+$P(IBVIENS,",",1)
. S PNB=$$PT^IBEFUNC(DFN)
. S PN=$P(PNB,U,1) ; pt name
. S LPID=$P(PNB,U,2) ; pt id
. S INS=+$P($G(^DPT(DFN,.312,IBCDFN,0)),U,1),INSNM=""
. I INS S INSNM=$P($G(^DIC(36,INS,0)),U,1)
. S IENS=IBCDFN_","_DFN_","
. S RSDATE=$$GET1^DIQ(2.312,IENS,8.01,"I"),RSTYPE=$$GET1^DIQ(2.312,IENS,8.02,"I")
. S VALMHDR(1)=$$FO^IBCNEUT1(PN,30)_" "_$$FO^IBCNEUT1(LPID,15)_" "_$$FO^IBCNEUT1(INSNM,30)
. S VALMHDR(2)="** Based on service date "_$S(RSDATE:$$FMTE^XLFDT(RSDATE,"5Z"),1:"UNKNOWN")_" and service type: "_$S(RSTYPE:$P($G(^IBE(365.013,RSTYPE,0)),U,2),1:"UNKNOWN")_" **"
. Q
;
; eIV response file
I IBVF=365.02 D
. N RSPIEN,IBX,DFN,INS,PNB,PN,LPID,INSNM,TQIEN,NODE0,RSTYPE,RSDATE
. S RSPIEN=+IBVIENS
. S IBX=$G(^IBCN(365,RSPIEN,0))
. ; IB*702/TAZ,CKB - Set the RSTYPE=REQUESTED SERVICE TYPE CODE (365,.15), and
. ; RSDATE=REQUESTED SERVICE DATE (365,.14)
. ;S TQIEN=$P(IBX,U,5),NODE0=$G(^IBCN(365.1,TQIEN,0)),RSTYPE=$P(NODE0,U,20)
. S RSTYPE=$$GET1^DIQ(365,RSPIEN_",",.15,"I")
. ;S RSDATE=$P($G(^IBCN(365,RSPIEN,1)),U,10) I RSDATE="" S RSDATE=$P(NODE0,U,12)
. S RSDATE=$P($G(^IBCN(365,RSPIEN,1)),U,10) I RSDATE="" S RSDATE=$$GET1^DIQ(365,RSPIEN_",",.14,"I")
. S DFN=+$P(IBX,U,2) ; pt ien
. S INS=+$P(IBX,U,3) ; payer ien
. S INSNM=""
. S PNB=$$PT^IBEFUNC(DFN)
. S PN=$P(PNB,U,1) ; pt name
. S LPID=$P(PNB,U,2) ; pt id
. I INS S INSNM=$P($G(^IBE(365.12,INS,0)),U,1) ; payer name
. S VALMHDR(1)=$$FO^IBCNEUT1(PN,30)_" "_$$FO^IBCNEUT1(LPID,15)_" "_$$FO^IBCNEUT1(INSNM,30)
. S VALMHDR(2)="** Based on service date "_$S(RSDATE:$$FMTE^XLFDT(RSDATE,"5Z"),1:"UNKNOWN")_" and service type: "_$S(RSTYPE:$P($G(^IBE(365.013,RSTYPE,0)),U,2),1:"UNKNOWN")_" **"
. Q
;
I $G(IBBUFDA) D
.N SRVARRAY,Z
.D SERVLN^IBCNBLE(IBBUFDA,.SRVARRAY) I SRVARRAY F Z=1:1:SRVARRAY S VALMHDR(Z+1)=SRVARRAY(Z)
.Q
Q
;
INIT(IBVF,IBVIENS,IBVEBFLG,IBVV,IBVSUB) ; List Entry
;
; IBVF = file# 2.322 or 365.02 (required)
; IBVIENS = std IENS list of internal entry numbers - NOT including any EB iens (required)
; IBVEBFLG = flag indicating which EB records to pull
; "A" - all of them
; "L" - only the last one (default)
; "F" - only the first one
; "M" - multiple, pass IBEBFLG by reference and include the IB iens in
; an array as follows:
; IBVEBFLG="M"
; IBVEBFLG(3)=""
; IBVEBFLG(5)=""
; IBVV = Video attributes flag
; 1 = reverse video (default)
; 2 = bold
; 3 = underline
; IBVSUB = literal subscript to use in the display scratch global
;
N IBVDA,GLO,IBVLIST,IEN,IBVEBIEN,IBVEBTOT,IBVEBCNT
N IBECODE,IIVSTAT,PLNDESC,IBINSTYP,OTHINS,MWNRIEN ;IB*2.0*506
;
S OTHINS=0 ;IB*2.0*506/TAZ Initialize Other Insurance variable
S MWNRIEN=$P($G(^IBE(350.9,1,51)),U,25) ;IB*2.0*506/TAZ Initialize Medicare WNR payer IEN
S IBVSUB=$G(IBVSUB)
I IBVSUB="" S IBVSUB="EB ELIG/BEN"
K ^TMP(IBVSUB,$J)
I $D(VALMEVL) D CLEAN^VALM10,KILL^VALM10()
;
D DA^DILF(IBVIENS,.IBVDA) ; build the IBVDA array for the iens
I '$D(IBVDA) D NODATA G INITX
;
I $D(VALMEVL),'$G(IBVV) S IBVV=1 ; default reverse video for ListMan
I '$D(VALMEVL) S IBVV="" ; no video attributes for non-ListMan
;
D RPDM^IBCNES3($S(IBVF=365.02:365,1:2.312),.IBVDA,IBVV,IBVSUB) ; IB*2*497 display group level eligibility information
;
I IBVF=2.322 S GLO=$NA(^DPT(+$G(IBVDA(1)),.312,+$G(IBVDA),6)) ; pt. insurance
I IBVF=365.02 S GLO=$NA(^IBCN(365,+$G(IBVDA),2)) ; response file
I $G(GLO)="" D NODATA G INITX
;
S IBVEBFLG=$G(IBVEBFLG,"L")
K IBVLIST
I IBVEBFLG="L" S IEN=+$O(@GLO@(" "),-1) I IEN S IBVLIST(IEN)="" ; last EB ien on file
I IBVEBFLG="F" S IEN=+$O(@GLO@(0)) I IEN S IBVLIST(IEN)="" ; first EB ien on file
I IBVEBFLG="A" S IEN=0 F S IEN=$O(@GLO@(IEN)) Q:'IEN S IBVLIST(IEN)="" ; all EB iens on file
I IBVEBFLG="M" S IEN=0 F S IEN=$O(IBVEBFLG(IEN)) Q:'IEN I $D(@GLO@(IEN)) S IBVLIST(IEN)="" ; multiple
;
I '$D(IBVLIST) D NODATA G INITX
;
; count them
S IEN=0 F IBVEBTOT=0:1 S IEN=$O(IBVLIST(IEN)) Q:'IEN
I 'IBVEBTOT D NODATA G INITX
;
; /IB*2.0*506 Beginning
; Count EBs and gather EB Summary Data
; IIVSTAT will tell us the coverage status 1,6, or V (File #365.011)
; Flag related to IBINSTYP will tell us the insurance type (File #365.014)
; OTHINS will tell us if Other Insurance was indicated on the response
;
S (IEN,IBVEBTOT,OTHINS)=0,(IIVSTAT,IBINSTYP,PLNDESC)=""
F S IEN=$O(IBVLIST(IEN)) D Q:'IEN
. Q:'IEN
. S IBVEBTOT=IBVEBTOT+1 ; total # of EBs
. I IBVEBTOT=1 D
. . S IBECODE=$P($G(@GLO@(1,0)),U,2) ; Eligibility/Benefits Code
. . S PLNDESC=$P($G(@GLO@(1,0)),U,6) ; Plan Description
. . I PLNDESC'="eIV Eligibility Determination" S IIVSTAT="V"
. . I IBECODE=1 S IIVSTAT=1 ; active
. . I IBECODE=6 S IIVSTAT=6 ; inactive
. . I IIVSTAT="" S IIVSTAT="V" ; ambigious
. . ;
. I IBINSTYP="" D
. . S IBINSTYP=$P($G(@GLO@(IEN,0)),U,5) ; Insurance Type (check all EBs, get 1st occurrence)
. . I IBINSTYP="" Q ; no insurance type found
. . S IBINSTYP=$$GET1^DIQ(365.014,IBINSTYP,.02)
. ;
. ;Screen out non_Medicare records
. S MWNRIEN=$P($G(^IBE(350.9,1,51)),U,25) ; Initialize Medicare WNR payer IEN
. I IBVF=2.322,($$GET1^DIQ(36,$P(^DPT(+$G(IBVDA(1)),.312,+$G(IBVDA),0),U,1)_",",3.1,"I")'=MWNRIEN) Q
. I IBVF=365.02,($P(^IBCN(365,+$G(IBVDA),0),U,3)'=MWNRIEN) Q
. ;
. N IBEIEN,IBELIG
. S IBEIEN=0
. F S IBEIEN=$O(@GLO@(IBEIEN)) Q:'IBEIEN D I OTHINS Q
.. ;Get Eligibility Code. We want R codes only.
.. S IBELIG=$P($G(@GLO@(IBEIEN,0)),U,2) I $P($G(^IBE(365.011,IBELIG,0)),U,1)="R" S OTHINS=1
;
I IBVEBTOT D SUMMARY(IIVSTAT,IBINSTYP,OTHINS)
; /IB*2.0*506 End
;
I 'IBVEBTOT D NODATA G INITX
;
S (IBVEBIEN,IBVEBCNT)=0
F S IBVEBIEN=$O(IBVLIST(IBVEBIEN)) Q:'IBVEBIEN D
. S IBVEBCNT=IBVEBCNT+1
. N TXVIENS
. ;
. ; if there is more than 1 EB group, then display a header line for separation
. I IBVEBTOT>1 D
.. N DSP,LN,IBZ
.. S DSP=$NA(^TMP(IBVSUB,$J,"DISP"))
.. S LN=+$O(@DSP@(""),-1)
.. S IBZ="eIV Eligibility/Benefit Data Group# "_IBVEBCNT_" of "_IBVEBTOT
.. S IBZ=$$FO^IBCNEUT1($J("",20)_IBZ,80)
.. S LN=LN+1 D SET^IBCNES1(LN,1,IBZ,,IBVV)
.. S LN=LN+1 D SET^IBCNES1(LN)
.. Q
. ;
. ; add this EB ien to the list of iens
. S TXVIENS=IBVEBIEN_","_IBVIENS
. ;
. ; call the screen sections to build the display
. D EB^IBCNES1(IBVF,TXVIENS,IBVV,IBVSUB)
. D CMPI^IBCNES1(IBVF,TXVIENS,IBVV,IBVSUB)
. D HCSD^IBCNES1(IBVF,TXVIENS,IBVV,IBVSUB)
. D NTE^IBCNES1(IBVF,TXVIENS,IBVV,IBVSUB)
. D BRE^IBCNES1(IBVF,TXVIENS,IBVV,IBVSUB)
. ;
. Q
;
S VALMCNT=$O(^TMP(IBVSUB,$J,"DISP"," "),-1)
;
INITX ;
Q
;
SUMMARY(IIVSTAT,IBINSTYP,OTHINS) ; (New w/ IB*2.0*506) key data from the Eligibility Benefit Information
N DSP,LN,IBZ
;
S IIVSTAT=$S(IIVSTAT=1:"ACTIVE",IIVSTAT=6:"INACTIVE",1:"AMBIGUOUS")
;
S DSP=$NA(^TMP(IBVSUB,$J,"DISP"))
S LN=+$O(@DSP@(""),-1)
S IBZ="Summary of eIV Eligibility/Benefit Data"
S IBZ=$$FO^IBCNEUT1($J("",20)_IBZ,80)
S LN=LN+1 D SET^IBCNES1(LN,1,IBZ,,IBVV)
S LN=LN+1 D SET^IBCNES1(LN)
;
S LN=LN+1 D SET^IBCNES1(LN,1,"Coverage Status",IIVSTAT)
S LN=LN+1 D SET^IBCNES1(LN,1,"Insurance Type",IBINSTYP)
;
I OTHINS S LN=LN+1 D SET^IBCNES1(LN,1,"Other insurance was potentially found")
S LN=LN+1 D SET^IBCNES1(LN)
Q
;
NODATA ; display no data found
N DSP,LN
S DSP=$NA(^TMP(IBVSUB,$J,"DISP")) ; scratch global display array
S LN=+$O(@DSP@(""),-1) ; last line# used in scratch global
S LN=LN+1 D SET^IBCNES1(LN)
S LN=LN+1 D SET^IBCNES1(LN,5,"No eIV Eligibility/Benefit Data Found")
S VALMCNT=$O(^TMP(IBVSUB,$J,"DISP"," "),-1)
NODATAX ;
Q
;
HELP ; -- help code
S X="?",VALMANS="??" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP(IBVSUB,$J)
I $D(VALMEVL) D CLEAN^VALM10,KILL^VALM10()
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNES 8880 printed Sep 23, 2025@19:51:35 Page 2
IBCNES ;ALB/ESG - eIV elig/Benefit screen ; 14-Jul-2009
+1 ;;2.0;INTEGRATED BILLING;**416,438,497,506,702**;21-MAR-94;Build 53
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EB(IBVF,IBVIENS,IBVEBFLG,IBVV,IBVSUB) ; entry point for main list display
+1 ; see below at tag INIT for a description of the parameters
+2 ; IBVSUB is required at this entry point because the ListMan array uses this variable
+3 ;
+4 DO EN^VALM("IBCNE ELIGIBILITY/BENEFIT INFO")
EBX ;
+1 QUIT
+2 ;
HDR ; -- header code - called by ListManager
+1 ; build the header area based on the values of IBVF and IBVIENS
+2 ;
+3 ; pt. insurance
+4 IF IBVF=2.322
Begin DoDot:1
+5 NEW DFN,IBCDFN,PNB,PN,LPID,INS,INSNM,IENS,RSDATE,RSTYPE
+6 SET DFN=+$PIECE(IBVIENS,",",2)
+7 SET IBCDFN=+$PIECE(IBVIENS,",",1)
+8 SET PNB=$$PT^IBEFUNC(DFN)
+9 ; pt name
SET PN=$PIECE(PNB,U,1)
+10 ; pt id
SET LPID=$PIECE(PNB,U,2)
+11 SET INS=+$PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),U,1)
SET INSNM=""
+12 IF INS
SET INSNM=$PIECE($GET(^DIC(36,INS,0)),U,1)
+13 SET IENS=IBCDFN_","_DFN_","
+14 SET RSDATE=$$GET1^DIQ(2.312,IENS,8.01,"I")
SET RSTYPE=$$GET1^DIQ(2.312,IENS,8.02,"I")
+15 SET VALMHDR(1)=$$FO^IBCNEUT1(PN,30)_" "_$$FO^IBCNEUT1(LPID,15)_" "_$$FO^IBCNEUT1(INSNM,30)
+16 SET VALMHDR(2)="** Based on service date "_$SELECT(RSDATE:$$FMTE^XLFDT(RSDATE,"5Z"),1:"UNKNOWN")_" and service type: "_$SELECT(RSTYPE:$PIECE($GET(^IBE(365.013,RSTYPE,0)),U,2),1:"UNKNOWN")_" **"
+17 QUIT
End DoDot:1
+18 ;
+19 ; eIV response file
+20 IF IBVF=365.02
Begin DoDot:1
+21 NEW RSPIEN,IBX,DFN,INS,PNB,PN,LPID,INSNM,TQIEN,NODE0,RSTYPE,RSDATE
+22 SET RSPIEN=+IBVIENS
+23 SET IBX=$GET(^IBCN(365,RSPIEN,0))
+24 ; IB*702/TAZ,CKB - Set the RSTYPE=REQUESTED SERVICE TYPE CODE (365,.15), and
+25 ; RSDATE=REQUESTED SERVICE DATE (365,.14)
+26 ;S TQIEN=$P(IBX,U,5),NODE0=$G(^IBCN(365.1,TQIEN,0)),RSTYPE=$P(NODE0,U,20)
+27 SET RSTYPE=$$GET1^DIQ(365,RSPIEN_",",.15,"I")
+28 ;S RSDATE=$P($G(^IBCN(365,RSPIEN,1)),U,10) I RSDATE="" S RSDATE=$P(NODE0,U,12)
+29 SET RSDATE=$PIECE($GET(^IBCN(365,RSPIEN,1)),U,10)
IF RSDATE=""
SET RSDATE=$$GET1^DIQ(365,RSPIEN_",",.14,"I")
+30 ; pt ien
SET DFN=+$PIECE(IBX,U,2)
+31 ; payer ien
SET INS=+$PIECE(IBX,U,3)
+32 SET INSNM=""
+33 SET PNB=$$PT^IBEFUNC(DFN)
+34 ; pt name
SET PN=$PIECE(PNB,U,1)
+35 ; pt id
SET LPID=$PIECE(PNB,U,2)
+36 ; payer name
IF INS
SET INSNM=$PIECE($GET(^IBE(365.12,INS,0)),U,1)
+37 SET VALMHDR(1)=$$FO^IBCNEUT1(PN,30)_" "_$$FO^IBCNEUT1(LPID,15)_" "_$$FO^IBCNEUT1(INSNM,30)
+38 SET VALMHDR(2)="** Based on service date "_$SELECT(RSDATE:$$FMTE^XLFDT(RSDATE,"5Z"),1:"UNKNOWN")_" and service type: "_$SELECT(RSTYPE:$PIECE($GET(^IBE(365.013,RSTYPE,0)),U,2),1:"UNKNOWN")_" **"
+39 QUIT
End DoDot:1
+40 ;
+41 IF $GET(IBBUFDA)
Begin DoDot:1
+42 NEW SRVARRAY,Z
+43 DO SERVLN^IBCNBLE(IBBUFDA,.SRVARRAY)
IF SRVARRAY
FOR Z=1:1:SRVARRAY
SET VALMHDR(Z+1)=SRVARRAY(Z)
+44 QUIT
End DoDot:1
+45 QUIT
+46 ;
INIT(IBVF,IBVIENS,IBVEBFLG,IBVV,IBVSUB) ; List Entry
+1 ;
+2 ; IBVF = file# 2.322 or 365.02 (required)
+3 ; IBVIENS = std IENS list of internal entry numbers - NOT including any EB iens (required)
+4 ; IBVEBFLG = flag indicating which EB records to pull
+5 ; "A" - all of them
+6 ; "L" - only the last one (default)
+7 ; "F" - only the first one
+8 ; "M" - multiple, pass IBEBFLG by reference and include the IB iens in
+9 ; an array as follows:
+10 ; IBVEBFLG="M"
+11 ; IBVEBFLG(3)=""
+12 ; IBVEBFLG(5)=""
+13 ; IBVV = Video attributes flag
+14 ; 1 = reverse video (default)
+15 ; 2 = bold
+16 ; 3 = underline
+17 ; IBVSUB = literal subscript to use in the display scratch global
+18 ;
+19 NEW IBVDA,GLO,IBVLIST,IEN,IBVEBIEN,IBVEBTOT,IBVEBCNT
+20 ;IB*2.0*506
NEW IBECODE,IIVSTAT,PLNDESC,IBINSTYP,OTHINS,MWNRIEN
+21 ;
+22 ;IB*2.0*506/TAZ Initialize Other Insurance variable
SET OTHINS=0
+23 ;IB*2.0*506/TAZ Initialize Medicare WNR payer IEN
SET MWNRIEN=$PIECE($GET(^IBE(350.9,1,51)),U,25)
+24 SET IBVSUB=$GET(IBVSUB)
+25 IF IBVSUB=""
SET IBVSUB="EB ELIG/BEN"
+26 KILL ^TMP(IBVSUB,$JOB)
+27 IF $DATA(VALMEVL)
DO CLEAN^VALM10
DO KILL^VALM10()
+28 ;
+29 ; build the IBVDA array for the iens
DO DA^DILF(IBVIENS,.IBVDA)
+30 IF '$DATA(IBVDA)
DO NODATA
GOTO INITX
+31 ;
+32 ; default reverse video for ListMan
IF $DATA(VALMEVL)
IF '$GET(IBVV)
SET IBVV=1
+33 ; no video attributes for non-ListMan
IF '$DATA(VALMEVL)
SET IBVV=""
+34 ;
+35 ; IB*2*497 display group level eligibility information
DO RPDM^IBCNES3($SELECT(IBVF=365.02:365,1:2.312),.IBVDA,IBVV,IBVSUB)
+36 ;
+37 ; pt. insurance
IF IBVF=2.322
SET GLO=$NAME(^DPT(+$GET(IBVDA(1)),.312,+$GET(IBVDA),6))
+38 ; response file
IF IBVF=365.02
SET GLO=$NAME(^IBCN(365,+$GET(IBVDA),2))
+39 IF $GET(GLO)=""
DO NODATA
GOTO INITX
+40 ;
+41 SET IBVEBFLG=$GET(IBVEBFLG,"L")
+42 KILL IBVLIST
+43 ; last EB ien on file
IF IBVEBFLG="L"
SET IEN=+$ORDER(@GLO@(" "),-1)
IF IEN
SET IBVLIST(IEN)=""
+44 ; first EB ien on file
IF IBVEBFLG="F"
SET IEN=+$ORDER(@GLO@(0))
IF IEN
SET IBVLIST(IEN)=""
+45 ; all EB iens on file
IF IBVEBFLG="A"
SET IEN=0
FOR
SET IEN=$ORDER(@GLO@(IEN))
if 'IEN
QUIT
SET IBVLIST(IEN)=""
+46 ; multiple
IF IBVEBFLG="M"
SET IEN=0
FOR
SET IEN=$ORDER(IBVEBFLG(IEN))
if 'IEN
QUIT
IF $DATA(@GLO@(IEN))
SET IBVLIST(IEN)=""
+47 ;
+48 IF '$DATA(IBVLIST)
DO NODATA
GOTO INITX
+49 ;
+50 ; count them
+51 SET IEN=0
FOR IBVEBTOT=0:1
SET IEN=$ORDER(IBVLIST(IEN))
if 'IEN
QUIT
+52 IF 'IBVEBTOT
DO NODATA
GOTO INITX
+53 ;
+54 ; /IB*2.0*506 Beginning
+55 ; Count EBs and gather EB Summary Data
+56 ; IIVSTAT will tell us the coverage status 1,6, or V (File #365.011)
+57 ; Flag related to IBINSTYP will tell us the insurance type (File #365.014)
+58 ; OTHINS will tell us if Other Insurance was indicated on the response
+59 ;
+60 SET (IEN,IBVEBTOT,OTHINS)=0
SET (IIVSTAT,IBINSTYP,PLNDESC)=""
+61 FOR
SET IEN=$ORDER(IBVLIST(IEN))
Begin DoDot:1
+62 if 'IEN
QUIT
+63 ; total # of EBs
SET IBVEBTOT=IBVEBTOT+1
+64 IF IBVEBTOT=1
Begin DoDot:2
+65 ; Eligibility/Benefits Code
SET IBECODE=$PIECE($GET(@GLO@(1,0)),U,2)
+66 ; Plan Description
SET PLNDESC=$PIECE($GET(@GLO@(1,0)),U,6)
+67 IF PLNDESC'="eIV Eligibility Determination"
SET IIVSTAT="V"
+68 ; active
IF IBECODE=1
SET IIVSTAT=1
+69 ; inactive
IF IBECODE=6
SET IIVSTAT=6
+70 ; ambigious
IF IIVSTAT=""
SET IIVSTAT="V"
+71 ;
End DoDot:2
+72 IF IBINSTYP=""
Begin DoDot:2
+73 ; Insurance Type (check all EBs, get 1st occurrence)
SET IBINSTYP=$PIECE($GET(@GLO@(IEN,0)),U,5)
+74 ; no insurance type found
IF IBINSTYP=""
QUIT
+75 SET IBINSTYP=$$GET1^DIQ(365.014,IBINSTYP,.02)
End DoDot:2
+76 ;
+77 ;Screen out non_Medicare records
+78 ; Initialize Medicare WNR payer IEN
SET MWNRIEN=$PIECE($GET(^IBE(350.9,1,51)),U,25)
+79 IF IBVF=2.322
IF ($$GET1^DIQ(36,$PIECE(^DPT(+$GET(IBVDA(1)),.312,+$GET(IBVDA),0),U,1)_",",3.1,"I")'=MWNRIEN)
QUIT
+80 IF IBVF=365.02
IF ($PIECE(^IBCN(365,+$GET(IBVDA),0),U,3)'=MWNRIEN)
QUIT
+81 ;
+82 NEW IBEIEN,IBELIG
+83 SET IBEIEN=0
+84 FOR
SET IBEIEN=$ORDER(@GLO@(IBEIEN))
if 'IBEIEN
QUIT
Begin DoDot:2
+85 ;Get Eligibility Code. We want R codes only.
+86 SET IBELIG=$PIECE($GET(@GLO@(IBEIEN,0)),U,2)
IF $PIECE($GET(^IBE(365.011,IBELIG,0)),U,1)="R"
SET OTHINS=1
End DoDot:2
IF OTHINS
QUIT
End DoDot:1
if 'IEN
QUIT
+87 ;
+88 IF IBVEBTOT
DO SUMMARY(IIVSTAT,IBINSTYP,OTHINS)
+89 ; /IB*2.0*506 End
+90 ;
+91 IF 'IBVEBTOT
DO NODATA
GOTO INITX
+92 ;
+93 SET (IBVEBIEN,IBVEBCNT)=0
+94 FOR
SET IBVEBIEN=$ORDER(IBVLIST(IBVEBIEN))
if 'IBVEBIEN
QUIT
Begin DoDot:1
+95 SET IBVEBCNT=IBVEBCNT+1
+96 NEW TXVIENS
+97 ;
+98 ; if there is more than 1 EB group, then display a header line for separation
+99 IF IBVEBTOT>1
Begin DoDot:2
+100 NEW DSP,LN,IBZ
+101 SET DSP=$NAME(^TMP(IBVSUB,$JOB,"DISP"))
+102 SET LN=+$ORDER(@DSP@(""),-1)
+103 SET IBZ="eIV Eligibility/Benefit Data Group# "_IBVEBCNT_" of "_IBVEBTOT
+104 SET IBZ=$$FO^IBCNEUT1($JUSTIFY("",20)_IBZ,80)
+105 SET LN=LN+1
DO SET^IBCNES1(LN,1,IBZ,,IBVV)
+106 SET LN=LN+1
DO SET^IBCNES1(LN)
+107 QUIT
End DoDot:2
+108 ;
+109 ; add this EB ien to the list of iens
+110 SET TXVIENS=IBVEBIEN_","_IBVIENS
+111 ;
+112 ; call the screen sections to build the display
+113 DO EB^IBCNES1(IBVF,TXVIENS,IBVV,IBVSUB)
+114 DO CMPI^IBCNES1(IBVF,TXVIENS,IBVV,IBVSUB)
+115 DO HCSD^IBCNES1(IBVF,TXVIENS,IBVV,IBVSUB)
+116 DO NTE^IBCNES1(IBVF,TXVIENS,IBVV,IBVSUB)
+117 DO BRE^IBCNES1(IBVF,TXVIENS,IBVV,IBVSUB)
+118 ;
+119 QUIT
End DoDot:1
+120 ;
+121 SET VALMCNT=$ORDER(^TMP(IBVSUB,$JOB,"DISP"," "),-1)
+122 ;
INITX ;
+1 QUIT
+2 ;
SUMMARY(IIVSTAT,IBINSTYP,OTHINS) ; (New w/ IB*2.0*506) key data from the Eligibility Benefit Information
+1 NEW DSP,LN,IBZ
+2 ;
+3 SET IIVSTAT=$SELECT(IIVSTAT=1:"ACTIVE",IIVSTAT=6:"INACTIVE",1:"AMBIGUOUS")
+4 ;
+5 SET DSP=$NAME(^TMP(IBVSUB,$JOB,"DISP"))
+6 SET LN=+$ORDER(@DSP@(""),-1)
+7 SET IBZ="Summary of eIV Eligibility/Benefit Data"
+8 SET IBZ=$$FO^IBCNEUT1($JUSTIFY("",20)_IBZ,80)
+9 SET LN=LN+1
DO SET^IBCNES1(LN,1,IBZ,,IBVV)
+10 SET LN=LN+1
DO SET^IBCNES1(LN)
+11 ;
+12 SET LN=LN+1
DO SET^IBCNES1(LN,1,"Coverage Status",IIVSTAT)
+13 SET LN=LN+1
DO SET^IBCNES1(LN,1,"Insurance Type",IBINSTYP)
+14 ;
+15 IF OTHINS
SET LN=LN+1
DO SET^IBCNES1(LN,1,"Other insurance was potentially found")
+16 SET LN=LN+1
DO SET^IBCNES1(LN)
+17 QUIT
+18 ;
NODATA ; display no data found
+1 NEW DSP,LN
+2 ; scratch global display array
SET DSP=$NAME(^TMP(IBVSUB,$JOB,"DISP"))
+3 ; last line# used in scratch global
SET LN=+$ORDER(@DSP@(""),-1)
+4 SET LN=LN+1
DO SET^IBCNES1(LN)
+5 SET LN=LN+1
DO SET^IBCNES1(LN,5,"No eIV Eligibility/Benefit Data Found")
+6 SET VALMCNT=$ORDER(^TMP(IBVSUB,$JOB,"DISP"," "),-1)
NODATAX ;
+1 QUIT
+2 ;
HELP ; -- help code
+1 SET X="?"
SET VALMANS="??"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP(IBVSUB,$JOB)
+2 IF $DATA(VALMEVL)
DO CLEAN^VALM10
DO KILL^VALM10()
+3 QUIT
+4 ;
