IBCNES4 ;ALB/JNM - eIV elig/Benefit screen ; 06/08/2016
;;2.0;INTEGRATED BILLING;**549,702,763,806**;21-MAR-94;Build 19
;;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
;
; IB*806/DTG made changes to bring in line with the RR report
INIT2(IBVF) ; allows changing IBVF just for this routine
N INIEN,X1,TEMP,NOLBL
;
N IBA,IBB,IBCT,IBI3,IBI3Q,IBI4,IBI4T,IBLI,IBSA,IBSB,IBSADDR,IBSAR,IBSCTY,IBSUBGET
N IBSUBER,IBTDT,IBTDT1,IBTDT2,IBTDT3,IBVFS,IENS,PTRIEN ;IB*806/DTG
;
S INIEN=IBVDA,NOLBL=$G(IBNOLBL),IBNOLBL=0
S IENS=INIEN_"," ;IB*806/DTG
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)) ;IB*806/DTG removed ssn
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" ;IB*806/DTG
;E S TEMP="Patient Relationship to Subscriber" ;IB*806/DTG
S TEMP="HIPAA Relationship to Sub" ;IB*806/DTG
S PTRIEN=$$GET1^DIQ(IBVF,INIEN,8.01,"I") ;Pt. Rel to Sub - HIPAA
;D SET1(TEMP,$$GET1^DIQ(IBVF,INIEN,1.09)) ;IB*806/DTG
D SET2(TEMP,$$GET1^DIQ(365.037,PTRIEN_",",.02,"E")) ;IB*806/DTG
D SET1("Member ID",$$GET1^DIQ(IBVF,INIEN,1.18))
D SET2("COB",$$GET1^DIQ(IBVF,INIEN,1.13)) ;IB*806/DTG change to SET2
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)) ;IB*806/DTG removed
;
;IB*806/DTG add display of sub addr 5.01,5.02,5.03,5.04,5.05,5.06,5.07
D GETS^DIQ(IBVF,IENS,"4.01;5.01:5.07","IEN","IBSUBGET","IBSUBER")
S IBSADDR=$G(IBSUBGET(IBVF,IENS,5.01,"E"))
S IBSA=$G(IBSUBGET(IBVF,IENS,5.02,"E")) I IBSA'="" S IBSADDR=IBSADDR_" "_IBSA
S IBSCTY=$G(IBSUBGET(IBVF,IENS,5.03,"E"))
S IBSA=$G(IBSUBGET(IBVF,IENS,5.04,"I")),IBSA=$S(IBSA:$P($G(^DIC(5,IBSA,0)),U,2),1:"")
S IBSB=$G(IBSUBGET(IBVF,IENS,5.05,"E"))
;
I IBSCTY'=""!(IBSA'="")!(IBSB'="") D
. S IBSCTY=IBSCTY_" "_IBSA_" "_IBSB
I IBSADDR'=""!(IBSCTY'="") D
. D SET1(" Sub Address",IBSADDR)
. D SET1(," "_IBSCTY) ;City, State
S IBSA=$G(IBSUBGET(IBVF,IENS,5.06,"E")) I IBSA'="" D SET1(" Country",IBSA)
S IBSA=$G(IBSUBGET(IBVF,IENS,5.07,"E")) I IBSA'="" D SET1(" Subdivision",IBSA)
S IBSA=$G(IBSUBGET(IBVF,IENS,4.01,"E")) I IBSA'="" D SET1(" Error Text",IBSA)
;
; IB*806/DTG get the subscriber/patient/other dates
K IBSUBGET D GETS^DIQ(IBVF,IENS,"7*","IEN","IBSUBGET","IBSUBER")
S IBVFS=$S(IBVF=365:"365.07",1:"")
I 'IBVFS!('$D(IBSUBGET(IBVFS))) G INIT3S
;
K IBSAR
S IBCT=0,IBLI="" F S IBLI=$O(IBSUBGET(IBVFS,IBLI)) Q:IBLI="" D
. S IBI3=$G(IBSUBGET(IBVFS,IBLI,.03,"I")) I 'IBI3 Q ; must have the qualifer
. S IBI3Q=$$X12^IBCNERP2(365.026,IBI3)
. S IBI4=$G(IBSUBGET(IBVFS,IBLI,.04,"E")),IBI4T=$S(IBI4["C":"S",IBI4["D":"P",1:"O")
. S IBTDT="",IBTDT1=$G(IBSUBGET(IBVFS,IBLI,.02,"I")) I IBTDT1="" Q ; must have the date
. ; massage the dates
. D ;
.. S IBTDT1=$TR(IBTDT1," ","")
.. S IBTDT2=$$FMTE^XLFDT($$HL7TFM^XLFDT($P(IBTDT1,"-",1)),"5Z")
.. S IBTDT3=$$FMTE^XLFDT($$HL7TFM^XLFDT($P(IBTDT1,"-",2)),"5Z")
.. I IBTDT3="-1" S IBTDT3="" ;IB*806/dtg Payers sometimes send bad dates ie:99991231
.. I IBTDT2="-1" S IBTDT2=""
.. S IBTDT=IBTDT2 I IBTDT1["-" S IBTDT=IBTDT_" - "_IBTDT3
. ;
. S IBCT=$G(IBSAR(IBI4T,0))+1,IBSAR(IBI4T,0)=IBCT
. S IBSAR(IBI4T,IBCT)=IBI3Q_U_IBTDT
;
F IBA="S","P","O" D
. I $O(IBSAR(IBA,0)) D SET1(),SET1($S(IBA="S":"Subscriber",IBA="P":"Patient",1:"Other")_" Dates",,1,1)
. ;
. S IBCT=0 F S IBCT=$O(IBSAR(IBA,IBCT)) Q:'IBCT S IBB=$G(IBSAR(IBA,IBCT)) I IBB'="" D
. . D SET1($P(IBB,U,1),$P(IBB,U,2)) ;,SET2("",$P(IBB,U,2))
;
INIT3S ; skip around tag for S/P/O dates not there
;
D SET1()
S IBNOLBL=0
;D SET1("Contact Information",,1,1) ; IB*806/DTG
I $O(^IBCN(IBVF,IBVDA,3,0)) D SET1("Contact Information",,1,1)
S X1=0 F S X1=$O(^IBCN(IBVF,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("Contact Person",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 8388 printed Jan 29, 2026@15:14:20 Page 2
IBCNES4 ;ALB/JNM - eIV elig/Benefit screen ; 06/08/2016
+1 ;;2.0;INTEGRATED BILLING;**549,702,763,806**;21-MAR-94;Build 19
+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 ;
+5 ; IB*806/DTG made changes to bring in line with the RR report
INIT2(IBVF) ; allows changing IBVF just for this routine
+1 NEW INIEN,X1,TEMP,NOLBL
+2 ;
+3 NEW IBA,IBB,IBCT,IBI3,IBI3Q,IBI4,IBI4T,IBLI,IBSA,IBSB,IBSADDR,IBSAR,IBSCTY,IBSUBGET
+4 ;IB*806/DTG
NEW IBSUBER,IBTDT,IBTDT1,IBTDT2,IBTDT3,IBVFS,IENS,PTRIEN
+5 ;
+6 SET INIEN=IBVDA
SET NOLBL=$GET(IBNOLBL)
SET IBNOLBL=0
+7 ;IB*806/DTG
SET IENS=INIEN_","
+8 DO SET1("Payer Summary - from Payer's Response",,1,1)
+9 ; If Response requested but not yet received
IF $$GET1^DIQ(IBVF,INIEN,.07,"I")'>0
DO WAITING
QUIT
+10 SET IBNOLBL=NOLBL
+11 DO SET1("Subscriber",$$GET1^DIQ(IBVF,INIEN,13.01))
+12 DO SET1("Subscriber ID",$$GET1^DIQ(IBVF,INIEN,13.02))
+13 DO SET1("Subscriber DOB",$$FMTE^XLFDT($$GET1^DIQ(IBVF,INIEN,1.02)))
+14 ;D SET1("Subscriber SSN",$$GET1^DIQ(IBVF,INIEN,1.03)) ;IB*806/DTG removed ssn
+15 DO SET2("Subscriber Sex",$$GET1^DIQ(IBVF,INIEN,1.04))
+16 DO SET1("Group Name",$$GET1^DIQ(IBVF,INIEN,14.01))
+17 DO SET1("Group ID",$$GET1^DIQ(IBVF,INIEN,14.02))
+18 DO SET1("Whose Insurance",$$GET1^DIQ(IBVF,INIEN,1.08))
+19 ;I +$G(IBVEBCOL) S TEMP="Pt. Rel. to Subscriber" ;IB*806/DTG
+20 ;E S TEMP="Patient Relationship to Subscriber" ;IB*806/DTG
+21 ;IB*806/DTG
SET TEMP="HIPAA Relationship to Sub"
+22 ;Pt. Rel to Sub - HIPAA
SET PTRIEN=$$GET1^DIQ(IBVF,INIEN,8.01,"I")
+23 ;D SET1(TEMP,$$GET1^DIQ(IBVF,INIEN,1.09)) ;IB*806/DTG
+24 ;IB*806/DTG
DO SET2(TEMP,$$GET1^DIQ(365.037,PTRIEN_",",.02,"E"))
+25 DO SET1("Member ID",$$GET1^DIQ(IBVF,INIEN,1.18))
+26 ;IB*806/DTG change to SET2
DO SET2("COB",$$GET1^DIQ(IBVF,INIEN,1.13))
+27 DO SET1("Service Date",$$GET1^DIQ(IBVF,INIEN,1.1))
+28 DO SET2("Date of Death",$$GET1^DIQ(IBVF,INIEN,1.16))
+29 DO SET1("Effective Date",$$GET1^DIQ(IBVF,INIEN,1.11))
+30 DO SET2("Certification Date",$$GET1^DIQ(IBVF,INIEN,1.17))
+31 DO SET1("Expiration Date",$$GET1^DIQ(IBVF,INIEN,1.12))
+32 DO SET2("Payer Updated Policy",$$GET1^DIQ(IBVF,INIEN,1.19))
+33 DO SET1("Response Date",$$GET1^DIQ(IBVF,INIEN,.07))
+34 DO SET2("Trace #",$$GET1^DIQ(IBVF,INIEN,.09))
+35 ;D SET1("Policy Number",$$GET1^DIQ(IBVF,INIEN,1.2)) ;IB*806/DTG removed
+36 ;
+37 ;IB*806/DTG add display of sub addr 5.01,5.02,5.03,5.04,5.05,5.06,5.07
+38 DO GETS^DIQ(IBVF,IENS,"4.01;5.01:5.07","IEN","IBSUBGET","IBSUBER")
+39 SET IBSADDR=$GET(IBSUBGET(IBVF,IENS,5.01,"E"))
+40 SET IBSA=$GET(IBSUBGET(IBVF,IENS,5.02,"E"))
IF IBSA'=""
SET IBSADDR=IBSADDR_" "_IBSA
+41 SET IBSCTY=$GET(IBSUBGET(IBVF,IENS,5.03,"E"))
+42 SET IBSA=$GET(IBSUBGET(IBVF,IENS,5.04,"I"))
SET IBSA=$SELECT(IBSA:$PIECE($GET(^DIC(5,IBSA,0)),U,2),1:"")
+43 SET IBSB=$GET(IBSUBGET(IBVF,IENS,5.05,"E"))
+44 ;
+45 IF IBSCTY'=""!(IBSA'="")!(IBSB'="")
Begin DoDot:1
+46 SET IBSCTY=IBSCTY_" "_IBSA_" "_IBSB
End DoDot:1
+47 IF IBSADDR'=""!(IBSCTY'="")
Begin DoDot:1
+48 DO SET1(" Sub Address",IBSADDR)
+49 ;City, State
DO SET1(," "_IBSCTY)
End DoDot:1
+50 SET IBSA=$GET(IBSUBGET(IBVF,IENS,5.06,"E"))
IF IBSA'=""
DO SET1(" Country",IBSA)
+51 SET IBSA=$GET(IBSUBGET(IBVF,IENS,5.07,"E"))
IF IBSA'=""
DO SET1(" Subdivision",IBSA)
+52 SET IBSA=$GET(IBSUBGET(IBVF,IENS,4.01,"E"))
IF IBSA'=""
DO SET1(" Error Text",IBSA)
+53 ;
+54 ; IB*806/DTG get the subscriber/patient/other dates
+55 KILL IBSUBGET
DO GETS^DIQ(IBVF,IENS,"7*","IEN","IBSUBGET","IBSUBER")
+56 SET IBVFS=$SELECT(IBVF=365:"365.07",1:"")
+57 IF 'IBVFS!('$DATA(IBSUBGET(IBVFS)))
GOTO INIT3S
+58 ;
+59 KILL IBSAR
+60 SET IBCT=0
SET IBLI=""
FOR
SET IBLI=$ORDER(IBSUBGET(IBVFS,IBLI))
if IBLI=""
QUIT
Begin DoDot:1
+61 ; must have the qualifer
SET IBI3=$GET(IBSUBGET(IBVFS,IBLI,.03,"I"))
IF 'IBI3
QUIT
+62 SET IBI3Q=$$X12^IBCNERP2(365.026,IBI3)
+63 SET IBI4=$GET(IBSUBGET(IBVFS,IBLI,.04,"E"))
SET IBI4T=$SELECT(IBI4["C":"S",IBI4["D":"P",1:"O")
+64 ; must have the date
SET IBTDT=""
SET IBTDT1=$GET(IBSUBGET(IBVFS,IBLI,.02,"I"))
IF IBTDT1=""
QUIT
+65 ; massage the dates
+66 ;
Begin DoDot:2
+67 SET IBTDT1=$TRANSLATE(IBTDT1," ","")
+68 SET IBTDT2=$$FMTE^XLFDT($$HL7TFM^XLFDT($PIECE(IBTDT1,"-",1)),"5Z")
+69 SET IBTDT3=$$FMTE^XLFDT($$HL7TFM^XLFDT($PIECE(IBTDT1,"-",2)),"5Z")
+70 ;IB*806/dtg Payers sometimes send bad dates ie:99991231
IF IBTDT3="-1"
SET IBTDT3=""
+71 IF IBTDT2="-1"
SET IBTDT2=""
+72 SET IBTDT=IBTDT2
IF IBTDT1["-"
SET IBTDT=IBTDT_" - "_IBTDT3
End DoDot:2
+73 ;
+74 SET IBCT=$GET(IBSAR(IBI4T,0))+1
SET IBSAR(IBI4T,0)=IBCT
+75 SET IBSAR(IBI4T,IBCT)=IBI3Q_U_IBTDT
End DoDot:1
+76 ;
+77 FOR IBA="S","P","O"
Begin DoDot:1
+78 IF $ORDER(IBSAR(IBA,0))
DO SET1()
DO SET1($SELECT(IBA="S":"Subscriber",IBA="P":"Patient",1:"Other")_" Dates",,1,1)
+79 ;
+80 SET IBCT=0
FOR
SET IBCT=$ORDER(IBSAR(IBA,IBCT))
if 'IBCT
QUIT
SET IBB=$GET(IBSAR(IBA,IBCT))
IF IBB'=""
Begin DoDot:2
+81 ;,SET2("",$P(IBB,U,2))
DO SET1($PIECE(IBB,U,1),$PIECE(IBB,U,2))
End DoDot:2
End DoDot:1
+82 ;
INIT3S ; skip around tag for S/P/O dates not there
+1 ;
+2 DO SET1()
+3 SET IBNOLBL=0
+4 ;D SET1("Contact Information",,1,1) ; IB*806/DTG
+5 IF $ORDER(^IBCN(IBVF,IBVDA,3,0))
DO SET1("Contact Information",,1,1)
+6 SET X1=0
FOR
SET X1=$ORDER(^IBCN(IBVF,IBVDA,3,X1))
if X1'=+X1
QUIT
Begin DoDot:1
+7 NEW DATA,STRTLINE,QFILE,QIEN
+8 SET STRTLINE=LN
+9 SET QFILE=365.03
SET QIEN=X1_","_IBVDA
+10 SET DATA=$$GET1^DIQ(QFILE,QIEN,.01)
+11 IF DATA'=""
DO SET1("Contact Person",DATA)
+12 DO SET4($$GETQUAL(.02),$$GET1^DIQ(QFILE,QIEN,1))
+13 DO SET4($$GETQUAL(.04),$$GET1^DIQ(QFILE,QIEN,2))
+14 DO SET4($$GETQUAL(.06),$$GET1^DIQ(QFILE,QIEN,3))
+15 if STRTLINE'=LN
DO SET1()
End DoDot:1
+16 DO SET1()
+17 QUIT
+18 ;
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 ;
