IBCNES4 ;ALB/JNM - eIV elig/Benefit screen ; 06/08/2016
;;2.0;INTEGRATED BILLING;**549,702,763**;21-MAR-94;Build 29
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; entry point for IBCNB ELIG PAYER SUMMARY action protocol
;IB*702/CKB,TAZ,DJW - Fixed restore of IBVF and IBVIENS
N IBVF2,IBVIENS2
S IBVF2=IBVF,IBVIENS2=IBVIENS
I +IBVIENS,+IBVF D
. D EN^VALM("IBCNB INSURANCE BUFFER PAYER")
ENX ;
S IBVF=IBVF2,IBVIENS=IBVIENS2
S VALMBCK="R"
Q
;
HDR ; -- header code
D HDR^IBCNES
Q
;
INIT0(IBVF,IBVIENS,IBSUBID,IBNOLBL) ; -- Used by IBCNBCD to fetch data
D INIT(IBSUBID)
Q
;
INIT(IBSUBID) ; -- init variables and list array
;IB*702/CKB,TAZ,DJW - Fixed restore of IBVF and IBVIENS
;IB*763/TAZ - Add check for Purged Response records.
N IBVDA,LN,COL,COL1,COL2,PURGED,VALMAR ;,IBVF2,IBVIENS2
;S IBVF2=IBVF,IBVIENS2=IBVIENS
I $G(IBSUBID)="" S IBSUBID="IBCNES PAY SUM"
S VALMAR=$NA(^TMP(IBSUBID,$J))
K @VALMAR ; clear out the existing data, if any
S LN=0,COL1=2,COL2=47,PURGED=0
I IBVF=2.322 D
. N IEN
. S IEN=$$GET1^DIQ(2.312,IBVIENS,8.03,"I")
. I '$G(IEN) Q
. I '$D(^IBCN(365,IEN)) S PURGED=1 Q
. S IBVF=365.02,IBVIENS=IEN_","
;IB*702/TAZ,CKB,DJW cleaned up the code for readability, changed G's to D's and
; moved INITX tag
;IB*763/TAZ - Print Purged message if PURGED variable is set then exit.
I PURGED D G INITX
. D SET1()
. D SET4("","The Payer Response is no longer on file.")
I IBVF=2.322 D NODATA G INITX
D DA^DILF(IBVIENS,.IBVDA) ; build the IBVDA array for the iens
I '$D(IBVDA) D NODATA G INITX
D INIT2(365)
;
INITX ;
;S IBVF=IBVF2,IBVIENS=IBVIENS2
S VALMCNT=LN
Q
;
INIT2(IBVF) ; allows changing IBVF just for this routine
N INIEN,X1,TEMP,NOLBL
S INIEN=IBVDA,NOLBL=$G(IBNOLBL),IBNOLBL=0
D SET1("Payer Summary - from Payer's Response",,1,1)
I $$GET1^DIQ(IBVF,INIEN,.07,"I")'>0 D WAITING Q ; If Response requested but not yet received
S IBNOLBL=NOLBL
D SET1("Subscriber",$$GET1^DIQ(IBVF,INIEN,13.01))
D SET1("Subscriber ID",$$GET1^DIQ(IBVF,INIEN,13.02))
D SET1("Subscriber DOB",$$FMTE^XLFDT($$GET1^DIQ(IBVF,INIEN,1.02)))
D SET1("Subscriber SSN",$$GET1^DIQ(IBVF,INIEN,1.03))
D SET2("Subscriber Sex",$$GET1^DIQ(IBVF,INIEN,1.04))
D SET1("Group Name",$$GET1^DIQ(IBVF,INIEN,14.01))
D SET1("Group ID",$$GET1^DIQ(IBVF,INIEN,14.02))
D SET1("Whose Insurance",$$GET1^DIQ(IBVF,INIEN,1.08))
I +$G(IBVEBCOL) S TEMP="Pt. Rel. to Subscriber"
E S TEMP="Patient Relationship to Subscriber"
D SET1(TEMP,$$GET1^DIQ(IBVF,INIEN,1.09))
D SET1("Member ID",$$GET1^DIQ(IBVF,INIEN,1.18))
D SET1("COB",$$GET1^DIQ(IBVF,INIEN,1.13))
D SET1("Service Date",$$GET1^DIQ(IBVF,INIEN,1.1))
D SET2("Date of Death",$$GET1^DIQ(IBVF,INIEN,1.16))
D SET1("Effective Date",$$GET1^DIQ(IBVF,INIEN,1.11))
D SET2("Certification Date",$$GET1^DIQ(IBVF,INIEN,1.17))
D SET1("Expiration Date",$$GET1^DIQ(IBVF,INIEN,1.12))
D SET2("Payer Updated Policy",$$GET1^DIQ(IBVF,INIEN,1.19))
D SET1("Response Date",$$GET1^DIQ(IBVF,INIEN,.07))
D SET2("Trace #",$$GET1^DIQ(IBVF,INIEN,.09))
D SET1("Policy Number",$$GET1^DIQ(IBVF,INIEN,1.2))
D SET1()
S IBNOLBL=0
D SET1("Contact Information",,1,1)
S X1=0 F S X1=$O(^IBCN(365,IBVDA,3,X1)) Q:X1'=+X1 D
. N DATA,STRTLINE,QFILE,QIEN
. S STRTLINE=LN
. S QFILE=365.03,QIEN=X1_","_IBVDA
. S DATA=$$GET1^DIQ(QFILE,QIEN,.01)
. I DATA'="" D SET1(DATA)
. D SET4($$GETQUAL(.02),$$GET1^DIQ(QFILE,QIEN,1))
. D SET4($$GETQUAL(.04),$$GET1^DIQ(QFILE,QIEN,2))
. D SET4($$GETQUAL(.06),$$GET1^DIQ(QFILE,QIEN,3))
. D:STRTLINE'=LN SET1()
D SET1()
Q
;
WAITING ;
D SET1()
;IB*763/TAZ - Removed trailing ":" for consistency
;D SET1("Awaiting Payer Response.")
D SET4("","Awaiting Payer Response.")
Q
;
NODATA ; display no data found
D SET1()
;IB*763/TAZ - Removed trailing ":" for consistency
;D SET1("No Payer Summary Data Found")
D SET4("","No Payer Summary Data Found")
Q
;
GETQUAL(QREC) ; Return Communication Qualifier text
N IEN
S IEN=$$GET1^DIQ(QFILE,QIEN,QREC,"I")
Q $$GET1^DIQ(365.021,+$G(IEN),.02)
;
SET2(LABEL,DATA,IBVV,COLUMN) ; Update previous line at COL2
I +$G(IBVEBCOL) D SET1($G(LABEL),$G(DATA),$G(IBVV),$G(COLUMN)) Q
S COL=COL2
G SETSTART
;
SET4(LABEL,DATA) ; print on column 4 if data is not blank
I ($G(LABEL)'="")!($G(DATA)'="") D SET1(LABEL,DATA,,4)
Q
;
SET1(LABEL,DATA,IBVV,COLUMN) ; Set next line at COL1
;
; IBVV - video attributes flag
; 1 = reverse video
; 2 = bold
; 3 = underline
;
S LN=LN+1
S COL=COL1
;
SETSTART ;
N STR,D1
I $G(COLUMN)>0 S COL=COLUMN
I $G(LABEL)'="",COL>1 S LABEL=" "_LABEL,COL=COL-1
S STR=$G(@VALMAR@(LN,0)) ; get the current string
S D1=""
I $G(IBNOLBL) S D1=$G(DATA)
E D
. I $G(LABEL)'="" S D1=LABEL_": "
. I $G(DATA)'="" S D1=D1_$G(DATA) ; build the new display
;
S STR=$$SETSTR^VALM1(D1,STR,+COL,(81-COL)) ; insert new data
;
D SET^VALM10(LN,STR)
;
; Add the video attributes if requested
I $G(IBVV) D
. I IBVV=1 D CNTRL^VALM10(LN,COL,$L(LABEL),IORVON,IORVOFF) ; reverse video
. I IBVV=2 D CNTRL^VALM10(LN,COL,$L(LABEL),IOINHI,IOINORM) ; bold
. I IBVV=3 D CNTRL^VALM10(LN,COL,$L(LABEL),IOUON,IOUOFF) ; underline
. Q
;
SETX ;
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNES4 5426 printed Sep 23, 2025@19:51:39 Page 2
IBCNES4 ;ALB/JNM - eIV elig/Benefit screen ; 06/08/2016
+1 ;;2.0;INTEGRATED BILLING;**549,702,763**;21-MAR-94;Build 29
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; entry point for IBCNB ELIG PAYER SUMMARY action protocol
+1 ;IB*702/CKB,TAZ,DJW - Fixed restore of IBVF and IBVIENS
+2 NEW IBVF2,IBVIENS2
+3 SET IBVF2=IBVF
SET IBVIENS2=IBVIENS
+4 IF +IBVIENS
IF +IBVF
Begin DoDot:1
+5 DO EN^VALM("IBCNB INSURANCE BUFFER PAYER")
End DoDot:1
ENX ;
+1 SET IBVF=IBVF2
SET IBVIENS=IBVIENS2
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
HDR ; -- header code
+1 DO HDR^IBCNES
+2 QUIT
+3 ;
INIT0(IBVF,IBVIENS,IBSUBID,IBNOLBL) ; -- Used by IBCNBCD to fetch data
+1 DO INIT(IBSUBID)
+2 QUIT
+3 ;
INIT(IBSUBID) ; -- init variables and list array
+1 ;IB*702/CKB,TAZ,DJW - Fixed restore of IBVF and IBVIENS
+2 ;IB*763/TAZ - Add check for Purged Response records.
+3 ;,IBVF2,IBVIENS2
NEW IBVDA,LN,COL,COL1,COL2,PURGED,VALMAR
+4 ;S IBVF2=IBVF,IBVIENS2=IBVIENS
+5 IF $GET(IBSUBID)=""
SET IBSUBID="IBCNES PAY SUM"
+6 SET VALMAR=$NAME(^TMP(IBSUBID,$JOB))
+7 ; clear out the existing data, if any
KILL @VALMAR
+8 SET LN=0
SET COL1=2
SET COL2=47
SET PURGED=0
+9 IF IBVF=2.322
Begin DoDot:1
+10 NEW IEN
+11 SET IEN=$$GET1^DIQ(2.312,IBVIENS,8.03,"I")
+12 IF '$GET(IEN)
QUIT
+13 IF '$DATA(^IBCN(365,IEN))
SET PURGED=1
QUIT
+14 SET IBVF=365.02
SET IBVIENS=IEN_","
End DoDot:1
+15 ;IB*702/TAZ,CKB,DJW cleaned up the code for readability, changed G's to D's and
+16 ; moved INITX tag
+17 ;IB*763/TAZ - Print Purged message if PURGED variable is set then exit.
+18 IF PURGED
Begin DoDot:1
+19 DO SET1()
+20 DO SET4("","The Payer Response is no longer on file.")
End DoDot:1
GOTO INITX
+21 IF IBVF=2.322
DO NODATA
GOTO INITX
+22 ; build the IBVDA array for the iens
DO DA^DILF(IBVIENS,.IBVDA)
+23 IF '$DATA(IBVDA)
DO NODATA
GOTO INITX
+24 DO INIT2(365)
+25 ;
INITX ;
+1 ;S IBVF=IBVF2,IBVIENS=IBVIENS2
+2 SET VALMCNT=LN
+3 QUIT
+4 ;
INIT2(IBVF) ; allows changing IBVF just for this routine
+1 NEW INIEN,X1,TEMP,NOLBL
+2 SET INIEN=IBVDA
SET NOLBL=$GET(IBNOLBL)
SET IBNOLBL=0
+3 DO SET1("Payer Summary - from Payer's Response",,1,1)
+4 ; If Response requested but not yet received
IF $$GET1^DIQ(IBVF,INIEN,.07,"I")'>0
DO WAITING
QUIT
+5 SET IBNOLBL=NOLBL
+6 DO SET1("Subscriber",$$GET1^DIQ(IBVF,INIEN,13.01))
+7 DO SET1("Subscriber ID",$$GET1^DIQ(IBVF,INIEN,13.02))
+8 DO SET1("Subscriber DOB",$$FMTE^XLFDT($$GET1^DIQ(IBVF,INIEN,1.02)))
+9 DO SET1("Subscriber SSN",$$GET1^DIQ(IBVF,INIEN,1.03))
+10 DO SET2("Subscriber Sex",$$GET1^DIQ(IBVF,INIEN,1.04))
+11 DO SET1("Group Name",$$GET1^DIQ(IBVF,INIEN,14.01))
+12 DO SET1("Group ID",$$GET1^DIQ(IBVF,INIEN,14.02))
+13 DO SET1("Whose Insurance",$$GET1^DIQ(IBVF,INIEN,1.08))
+14 IF +$GET(IBVEBCOL)
SET TEMP="Pt. Rel. to Subscriber"
+15 IF '$TEST
SET TEMP="Patient Relationship to Subscriber"
+16 DO SET1(TEMP,$$GET1^DIQ(IBVF,INIEN,1.09))
+17 DO SET1("Member ID",$$GET1^DIQ(IBVF,INIEN,1.18))
+18 DO SET1("COB",$$GET1^DIQ(IBVF,INIEN,1.13))
+19 DO SET1("Service Date",$$GET1^DIQ(IBVF,INIEN,1.1))
+20 DO SET2("Date of Death",$$GET1^DIQ(IBVF,INIEN,1.16))
+21 DO SET1("Effective Date",$$GET1^DIQ(IBVF,INIEN,1.11))
+22 DO SET2("Certification Date",$$GET1^DIQ(IBVF,INIEN,1.17))
+23 DO SET1("Expiration Date",$$GET1^DIQ(IBVF,INIEN,1.12))
+24 DO SET2("Payer Updated Policy",$$GET1^DIQ(IBVF,INIEN,1.19))
+25 DO SET1("Response Date",$$GET1^DIQ(IBVF,INIEN,.07))
+26 DO SET2("Trace #",$$GET1^DIQ(IBVF,INIEN,.09))
+27 DO SET1("Policy Number",$$GET1^DIQ(IBVF,INIEN,1.2))
+28 DO SET1()
+29 SET IBNOLBL=0
+30 DO SET1("Contact Information",,1,1)
+31 SET X1=0
FOR
SET X1=$ORDER(^IBCN(365,IBVDA,3,X1))
if X1'=+X1
QUIT
Begin DoDot:1
+32 NEW DATA,STRTLINE,QFILE,QIEN
+33 SET STRTLINE=LN
+34 SET QFILE=365.03
SET QIEN=X1_","_IBVDA
+35 SET DATA=$$GET1^DIQ(QFILE,QIEN,.01)
+36 IF DATA'=""
DO SET1(DATA)
+37 DO SET4($$GETQUAL(.02),$$GET1^DIQ(QFILE,QIEN,1))
+38 DO SET4($$GETQUAL(.04),$$GET1^DIQ(QFILE,QIEN,2))
+39 DO SET4($$GETQUAL(.06),$$GET1^DIQ(QFILE,QIEN,3))
+40 if STRTLINE'=LN
DO SET1()
End DoDot:1
+41 DO SET1()
+42 QUIT
+43 ;
WAITING ;
+1 DO SET1()
+2 ;IB*763/TAZ - Removed trailing ":" for consistency
+3 ;D SET1("Awaiting Payer Response.")
+4 DO SET4("","Awaiting Payer Response.")
+5 QUIT
+6 ;
NODATA ; display no data found
+1 DO SET1()
+2 ;IB*763/TAZ - Removed trailing ":" for consistency
+3 ;D SET1("No Payer Summary Data Found")
+4 DO SET4("","No Payer Summary Data Found")
+5 QUIT
+6 ;
GETQUAL(QREC) ; Return Communication Qualifier text
+1 NEW IEN
+2 SET IEN=$$GET1^DIQ(QFILE,QIEN,QREC,"I")
+3 QUIT $$GET1^DIQ(365.021,+$GET(IEN),.02)
+4 ;
SET2(LABEL,DATA,IBVV,COLUMN) ; Update previous line at COL2
+1 IF +$GET(IBVEBCOL)
DO SET1($GET(LABEL),$GET(DATA),$GET(IBVV),$GET(COLUMN))
QUIT
+2 SET COL=COL2
+3 GOTO SETSTART
+4 ;
SET4(LABEL,DATA) ; print on column 4 if data is not blank
+1 IF ($GET(LABEL)'="")!($GET(DATA)'="")
DO SET1(LABEL,DATA,,4)
+2 QUIT
+3 ;
SET1(LABEL,DATA,IBVV,COLUMN) ; Set next line at COL1
+1 ;
+2 ; IBVV - video attributes flag
+3 ; 1 = reverse video
+4 ; 2 = bold
+5 ; 3 = underline
+6 ;
+7 SET LN=LN+1
+8 SET COL=COL1
+9 ;
SETSTART ;
+1 NEW STR,D1
+2 IF $GET(COLUMN)>0
SET COL=COLUMN
+3 IF $GET(LABEL)'=""
IF COL>1
SET LABEL=" "_LABEL
SET COL=COL-1
+4 ; get the current string
SET STR=$GET(@VALMAR@(LN,0))
+5 SET D1=""
+6 IF $GET(IBNOLBL)
SET D1=$GET(DATA)
+7 IF '$TEST
Begin DoDot:1
+8 IF $GET(LABEL)'=""
SET D1=LABEL_": "
+9 ; build the new display
IF $GET(DATA)'=""
SET D1=D1_$GET(DATA)
End DoDot:1
+10 ;
+11 ; insert new data
SET STR=$$SETSTR^VALM1(D1,STR,+COL,(81-COL))
+12 ;
+13 DO SET^VALM10(LN,STR)
+14 ;
+15 ; Add the video attributes if requested
+16 IF $GET(IBVV)
Begin DoDot:1
+17 ; reverse video
IF IBVV=1
DO CNTRL^VALM10(LN,COL,$LENGTH(LABEL),IORVON,IORVOFF)
+18 ; bold
IF IBVV=2
DO CNTRL^VALM10(LN,COL,$LENGTH(LABEL),IOINHI,IOINORM)
+19 ; underline
IF IBVV=3
DO CNTRL^VALM10(LN,COL,$LENGTH(LABEL),IOUON,IOUOFF)
+20 QUIT
End DoDot:1
+21 ;
SETX ;
+1 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
