IBCNES3 ;DALOI/KML/JNM - eIV elig/Benefit screen, con't ; 05-JAN-2016
;;2.0;INTEGRATED BILLING;**497,549,806**;21-MAR-94;Build 19
;;Per VA Directive 6402, this routine should not be modified.
;
Q
; called by IBCNES
RPDM(IBVF,IBVDA,IBVV,IBVSUB) ; Eligibility/Group Information procedure
; --- Called by IBCNES
; input
; IBVF = file file# 2.322 or 365.02
; IBVDA - ien of 365 OR 2.312
S IBVV=+$G(IBVV)
N IBL,IBY,IBLINE,LN,DSP,COL1,COL2,GLO
N STARTLN ;IB*806/DJW Use to track if section had data or not
;
I IBVF=2.312 S GLO=$NA(^DPT(+$G(IBVDA(1)),.312,+$G(IBVDA))) ; pt. insurance
I IBVF=365 S GLO=$NA(^IBCN(365,+$G(IBVDA))) ; response file
S DSP=$NA(^TMP(IBVSUB,$J,"DISP")) ; scratch global display array
S LN=+$O(@DSP@(""),-1) ; last line# used in scratch global
S COL1=2,COL2=47
;
S STARTLN=LN
D REF(GLO,IBVF,STARTLN,.IBVDA)
D PROV(GLO,IBVF,STARTLN,.IBVDA)
D DIAG(GLO,IBVF,STARTLN,.IBVDA)
D MIL(GLO,IBVF,STARTLN,.IBVDA)
Q
;
GRPHDR ; Header for Elig/Grp Plan Info section
S LN=LN+1 D SET^IBCNES1(LN,22,"Eligibility/Group Plan Information",,IBVV) ;IB*806/DJW centered text
S LN=LN+1 D SET^IBCNES1(LN,22,"----------------------------------",,IBVV)
S LN=LN+1
GRPHDRX ;
Q
;
REF(GLO,IBVF,STARTLN,IBVDA) ; policy level reference ID display
; IB*806/DJW Reformatted display to only print populated fields
;
N REF,SIEN,IENS,REFLST
S IBVF=$S(IBVF=365:365.09,1:2.3129)
S SIEN=0 F S SIEN=$O(@GLO@(9,SIEN)) Q:'SIEN S REFLST(SIEN)=""
I '$D(REFLST) Q
I LN=STARTLN D GRPHDR
S SIEN=0 F S SIEN=$O(REFLST(SIEN)) Q:'SIEN D
. S IENS=$S(IBVF=365.09:SIEN_","_IBVDA_",",1:SIEN_","_IBVDA_","_IBVDA(1)_",")
. D GETS^DIQ(IBVF,IENS,"*","IEN","REF")
. I +$G(REF(IBVF,IENS,.03,"I"))'=0 D SET^IBCNES1(LN,COL1,"Reference ID Qualifier",$P($G(^IBE(365.028,+$G(REF(IBVF,IENS,.03,"I")),0)),U,2))
. I $G(REF(IBVF,IENS,.02,"E"))'="" S LN=LN+1 D SET^IBCNES1(LN,COL1+2,"Reference ID",$G(REF(IBVF,IENS,.02,"E")))
. I $G(REF(IBVF,IENS,.04,"E"))'="" S LN=LN+1 D SET^IBCNES1(LN,COL1+2,"Reference ID description",$G(REF(IBVF,IENS,.04,"E")))
. S LN=LN+1 D SET^IBCNES1(LN)
S LN=LN+1 D SET^IBCNES1(LN)
Q
;
PROV(GLO,IBVF,STARTLN,IBVDA) ; GROUP level provider info
; IB*806/DJW Reformatted display to only print populated fields
;
N PVLIST,SIEN,IENS,PV
S IBVF=$S(IBVF=365:365.04,1:2.332)
S SIEN=0 F S SIEN=$O(@GLO@(10,SIEN)) Q:'SIEN S PVLIST(SIEN)=""
I '$D(PVLIST) Q
I LN=STARTLN D GRPHDR
S SIEN=0 F S SIEN=$O(PVLIST(SIEN)) Q:'SIEN D
. S IENS=$S(IBVF=365.04:SIEN_","_IBVDA_",",1:SIEN_","_IBVDA_","_IBVDA(1)_",")
. D GETS^DIQ(IBVF,IENS,"*","IEN","PV")
. I +$G(PV(IBVF,IENS,.02,"I"))'=0 D SET^IBCNES1(LN,COL1,"Provider Code",$P($G(^IBE(365.024,+$G(PV(IBVF,IENS,.02,"I")),0)),U,2))
. I $G(PV(IBVF,IENS,.03,"E"))'="" S LN=LN+1 D SET^IBCNES1(LN,COL1,"Reference ID",$G(PV(IBVF,IENS,.03,"E")))
. S LN=LN+1 D SET^IBCNES1(LN)
S LN=LN+1 D SET^IBCNES1(LN)
Q
;
DIAG(GLO,IBVF,STARTLN,IBVDA) ; DIAGNOSIS INFO
; IB*806/DJW Reformatted display to only print populated fields
;
N IENS,SIEN,HDLIST,DIAG,ICDSTR,PRIMSEC
N IBTW ;IB*806/DTG additional item
S IBVF=$S(IBVF=365:365.01,1:2.31211)
S SIEN=0 F S SIEN=$O(@GLO@(11,SIEN)) Q:'SIEN S HDLIST(SIEN)=""
I '$D(HDLIST) Q
I LN=STARTLN D GRPHDR
S SIEN=0 F S SIEN=$O(HDLIST(SIEN)) Q:'SIEN D
. S IENS=$S(IBVF=365.01:SIEN_","_IBVDA_",",1:SIEN_","_IBVDA_","_IBVDA(1)_",")
. D GETS^DIQ(IBVF,IENS,"*","IEN","DIAG")
. S ICDSTR=$G(^ICD9(+$G(DIAG(IBVF,IENS,.02,"I")),0)) ; IA# 5388 (Supported agreement)
. S PRIMSEC=$G(DIAG(IBVF,IENS,.04,"I")),IBTW=""
. I ICDSTR'="" D SET^IBCNES1(LN,COL1,$S(PRIMSEC="P":"Primary ",PRIMSEC="":"Primary ",1:"Secondary ")_"Diagnosis Code",$P(ICDSTR,U)_" "_$P(ICDSTR,U,3))
. S:ICDSTR'="" LN=LN+1 S IBTW=$G(DIAG(IBVF,IENS,.03,"E"))
. I IBTW'="" D SET^IBCNES1(LN,(COL1+2),"Diag Code Qualifier",IBTW) S LN=LN+1 ;IB*806/DTG additional item
. S LN=LN+1 D SET^IBCNES1(LN)
S LN=LN+1 D SET^IBCNES1(LN)
Q
;
MIL(GLO,IBVF,STARTLN,IBVDA) ; military personnel information display
; IB*806/DJW Reformatted display to only print populated fields
; and in a single column display
;
N IENS,XX,MIL
S IENS=IBVDA_","
S IENS=$S(IBVF=365:IBVDA_",",1:IBVDA_","_IBVDA(1)_",")
S IBVF=$S(IBVF=365:365,1:2.312)
D GETS^DIQ(IBVF,IENS,"12.01:12.07","IEN","MIL")
;
I '$D(MIL) Q
I LN=STARTLN D GRPHDR
S XX=+$G(MIL(IBVF,IENS,12.01,"I"))
I XX'=0 D SET^IBCNES1(LN,COL1,"Military Info Status",$P($G(^IBE(365.039,XX,0)),U,2))
S XX=+$G(MIL(IBVF,IENS,12.02,"I"))
I XX'=0 S LN=LN+1 D SET^IBCNES1(LN,COL1,"Employment Status",$P($G(^IBE(365.046,XX,0)),U,2))
S XX=+$G(MIL(IBVF,IENS,12.03,"I"))
I XX'=0 S LN=LN+1 D SET^IBCNES1(LN,COL1,"Government Affiliation",$P($G(^IBE(365.041,XX,0)),U,2))
S XX=$$DFMT(.MIL,IBVF,IENS)
I XX'="" S LN=LN+1 D SET^IBCNES1(.LN,COL1,"Date Time Period",XX)
S XX=+$G(MIL(IBVF,IENS,12.05,"I"))
I XX'=0 S LN=LN+1 D SET^IBCNES1(LN,COL1,"Service Rank",$P($G(^IBE(365.042,XX,0)),U,2))
S XX=$G(MIL(IBVF,IENS,12.04,"E"))
I XX'="" S LN=LN+1 D SET^IBCNES1(LN,COL1,"Desc",XX)
S LN=LN+1 D SET^IBCNES1(LN)
Q
;
DFMT(MIL,IBVF,IENS) ; return proper date format string
;
; input - MIL = data array containing the data extracted from the military information fields (365, 12.01-12.07)
; IENS = ien of 365 entry or 2.312 entry
; output - RES = formatted date string
N TODT,FROMDT,RES
; date range
I $G(MIL(IBVF,IENS,12.06,"E"))="RD8" S FROMDT=$P($G(MIL(IBVF,IENS,12.07,"E")),"-"),TODT=$P($G(MIL(IBVF,IENS,12.07,"E")),"-",2),RES=$$FMTE^XLFDT($$HL7TFM^XLFDT(FROMDT),2)_" - "_$$FMTE^XLFDT($$HL7TFM^XLFDT(TODT),2)
E S RES=$$FMTE^XLFDT($$HL7TFM^XLFDT($G(MIL(IBVF,IENS,12.07,"E"))),2) ; single date
Q RES
;
SET(LN,DATA,COL) ;set display data in scratch global
N STR
S STR=""
S STR=$$SETSTR^VALM1(DATA,STR,+COL,(81-COL)) ; insert new data
S @DSP@(LN,0)=STR ; set the new data back into the scratch global
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNES3 6084 printed Jan 29, 2026@15:14:19 Page 2
IBCNES3 ;DALOI/KML/JNM - eIV elig/Benefit screen, con't ; 05-JAN-2016
+1 ;;2.0;INTEGRATED BILLING;**497,549,806**;21-MAR-94;Build 19
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ; called by IBCNES
RPDM(IBVF,IBVDA,IBVV,IBVSUB) ; Eligibility/Group Information procedure
+1 ; --- Called by IBCNES
+2 ; input
+3 ; IBVF = file file# 2.322 or 365.02
+4 ; IBVDA - ien of 365 OR 2.312
+5 SET IBVV=+$GET(IBVV)
+6 NEW IBL,IBY,IBLINE,LN,DSP,COL1,COL2,GLO
+7 ;IB*806/DJW Use to track if section had data or not
NEW STARTLN
+8 ;
+9 ; pt. insurance
IF IBVF=2.312
SET GLO=$NAME(^DPT(+$GET(IBVDA(1)),.312,+$GET(IBVDA)))
+10 ; response file
IF IBVF=365
SET GLO=$NAME(^IBCN(365,+$GET(IBVDA)))
+11 ; scratch global display array
SET DSP=$NAME(^TMP(IBVSUB,$JOB,"DISP"))
+12 ; last line# used in scratch global
SET LN=+$ORDER(@DSP@(""),-1)
+13 SET COL1=2
SET COL2=47
+14 ;
+15 SET STARTLN=LN
+16 DO REF(GLO,IBVF,STARTLN,.IBVDA)
+17 DO PROV(GLO,IBVF,STARTLN,.IBVDA)
+18 DO DIAG(GLO,IBVF,STARTLN,.IBVDA)
+19 DO MIL(GLO,IBVF,STARTLN,.IBVDA)
+20 QUIT
+21 ;
GRPHDR ; Header for Elig/Grp Plan Info section
+1 ;IB*806/DJW centered text
SET LN=LN+1
DO SET^IBCNES1(LN,22,"Eligibility/Group Plan Information",,IBVV)
+2 SET LN=LN+1
DO SET^IBCNES1(LN,22,"----------------------------------",,IBVV)
+3 SET LN=LN+1
GRPHDRX ;
+1 QUIT
+2 ;
REF(GLO,IBVF,STARTLN,IBVDA) ; policy level reference ID display
+1 ; IB*806/DJW Reformatted display to only print populated fields
+2 ;
+3 NEW REF,SIEN,IENS,REFLST
+4 SET IBVF=$SELECT(IBVF=365:365.09,1:2.3129)
+5 SET SIEN=0
FOR
SET SIEN=$ORDER(@GLO@(9,SIEN))
if 'SIEN
QUIT
SET REFLST(SIEN)=""
+6 IF '$DATA(REFLST)
QUIT
+7 IF LN=STARTLN
DO GRPHDR
+8 SET SIEN=0
FOR
SET SIEN=$ORDER(REFLST(SIEN))
if 'SIEN
QUIT
Begin DoDot:1
+9 SET IENS=$SELECT(IBVF=365.09:SIEN_","_IBVDA_",",1:SIEN_","_IBVDA_","_IBVDA(1)_",")
+10 DO GETS^DIQ(IBVF,IENS,"*","IEN","REF")
+11 IF +$GET(REF(IBVF,IENS,.03,"I"))'=0
DO SET^IBCNES1(LN,COL1,"Reference ID Qualifier",$PIECE($GET(^IBE(365.028,+$GET(REF(IBVF,IENS,.03,"I")),0)),U,2))
+12 IF $GET(REF(IBVF,IENS,.02,"E"))'=""
SET LN=LN+1
DO SET^IBCNES1(LN,COL1+2,"Reference ID",$GET(REF(IBVF,IENS,.02,"E")))
+13 IF $GET(REF(IBVF,IENS,.04,"E"))'=""
SET LN=LN+1
DO SET^IBCNES1(LN,COL1+2,"Reference ID description",$GET(REF(IBVF,IENS,.04,"E")))
+14 SET LN=LN+1
DO SET^IBCNES1(LN)
End DoDot:1
+15 SET LN=LN+1
DO SET^IBCNES1(LN)
+16 QUIT
+17 ;
PROV(GLO,IBVF,STARTLN,IBVDA) ; GROUP level provider info
+1 ; IB*806/DJW Reformatted display to only print populated fields
+2 ;
+3 NEW PVLIST,SIEN,IENS,PV
+4 SET IBVF=$SELECT(IBVF=365:365.04,1:2.332)
+5 SET SIEN=0
FOR
SET SIEN=$ORDER(@GLO@(10,SIEN))
if 'SIEN
QUIT
SET PVLIST(SIEN)=""
+6 IF '$DATA(PVLIST)
QUIT
+7 IF LN=STARTLN
DO GRPHDR
+8 SET SIEN=0
FOR
SET SIEN=$ORDER(PVLIST(SIEN))
if 'SIEN
QUIT
Begin DoDot:1
+9 SET IENS=$SELECT(IBVF=365.04:SIEN_","_IBVDA_",",1:SIEN_","_IBVDA_","_IBVDA(1)_",")
+10 DO GETS^DIQ(IBVF,IENS,"*","IEN","PV")
+11 IF +$GET(PV(IBVF,IENS,.02,"I"))'=0
DO SET^IBCNES1(LN,COL1,"Provider Code",$PIECE($GET(^IBE(365.024,+$GET(PV(IBVF,IENS,.02,"I")),0)),U,2))
+12 IF $GET(PV(IBVF,IENS,.03,"E"))'=""
SET LN=LN+1
DO SET^IBCNES1(LN,COL1,"Reference ID",$GET(PV(IBVF,IENS,.03,"E")))
+13 SET LN=LN+1
DO SET^IBCNES1(LN)
End DoDot:1
+14 SET LN=LN+1
DO SET^IBCNES1(LN)
+15 QUIT
+16 ;
DIAG(GLO,IBVF,STARTLN,IBVDA) ; DIAGNOSIS INFO
+1 ; IB*806/DJW Reformatted display to only print populated fields
+2 ;
+3 NEW IENS,SIEN,HDLIST,DIAG,ICDSTR,PRIMSEC
+4 ;IB*806/DTG additional item
NEW IBTW
+5 SET IBVF=$SELECT(IBVF=365:365.01,1:2.31211)
+6 SET SIEN=0
FOR
SET SIEN=$ORDER(@GLO@(11,SIEN))
if 'SIEN
QUIT
SET HDLIST(SIEN)=""
+7 IF '$DATA(HDLIST)
QUIT
+8 IF LN=STARTLN
DO GRPHDR
+9 SET SIEN=0
FOR
SET SIEN=$ORDER(HDLIST(SIEN))
if 'SIEN
QUIT
Begin DoDot:1
+10 SET IENS=$SELECT(IBVF=365.01:SIEN_","_IBVDA_",",1:SIEN_","_IBVDA_","_IBVDA(1)_",")
+11 DO GETS^DIQ(IBVF,IENS,"*","IEN","DIAG")
+12 ; IA# 5388 (Supported agreement)
SET ICDSTR=$GET(^ICD9(+$GET(DIAG(IBVF,IENS,.02,"I")),0))
+13 SET PRIMSEC=$GET(DIAG(IBVF,IENS,.04,"I"))
SET IBTW=""
+14 IF ICDSTR'=""
DO SET^IBCNES1(LN,COL1,$SELECT(PRIMSEC="P":"Primary ",PRIMSEC="":"Primary ",1:"Secondary ")_"Diagnosis Code",$PIECE(ICDSTR,U)_" "_$PIECE(ICDSTR,U,3))
+15 if ICDSTR'=""
SET LN=LN+1
SET IBTW=$GET(DIAG(IBVF,IENS,.03,"E"))
+16 ;IB*806/DTG additional item
IF IBTW'=""
DO SET^IBCNES1(LN,(COL1+2),"Diag Code Qualifier",IBTW)
SET LN=LN+1
+17 SET LN=LN+1
DO SET^IBCNES1(LN)
End DoDot:1
+18 SET LN=LN+1
DO SET^IBCNES1(LN)
+19 QUIT
+20 ;
MIL(GLO,IBVF,STARTLN,IBVDA) ; military personnel information display
+1 ; IB*806/DJW Reformatted display to only print populated fields
+2 ; and in a single column display
+3 ;
+4 NEW IENS,XX,MIL
+5 SET IENS=IBVDA_","
+6 SET IENS=$SELECT(IBVF=365:IBVDA_",",1:IBVDA_","_IBVDA(1)_",")
+7 SET IBVF=$SELECT(IBVF=365:365,1:2.312)
+8 DO GETS^DIQ(IBVF,IENS,"12.01:12.07","IEN","MIL")
+9 ;
+10 IF '$DATA(MIL)
QUIT
+11 IF LN=STARTLN
DO GRPHDR
+12 SET XX=+$GET(MIL(IBVF,IENS,12.01,"I"))
+13 IF XX'=0
DO SET^IBCNES1(LN,COL1,"Military Info Status",$PIECE($GET(^IBE(365.039,XX,0)),U,2))
+14 SET XX=+$GET(MIL(IBVF,IENS,12.02,"I"))
+15 IF XX'=0
SET LN=LN+1
DO SET^IBCNES1(LN,COL1,"Employment Status",$PIECE($GET(^IBE(365.046,XX,0)),U,2))
+16 SET XX=+$GET(MIL(IBVF,IENS,12.03,"I"))
+17 IF XX'=0
SET LN=LN+1
DO SET^IBCNES1(LN,COL1,"Government Affiliation",$PIECE($GET(^IBE(365.041,XX,0)),U,2))
+18 SET XX=$$DFMT(.MIL,IBVF,IENS)
+19 IF XX'=""
SET LN=LN+1
DO SET^IBCNES1(.LN,COL1,"Date Time Period",XX)
+20 SET XX=+$GET(MIL(IBVF,IENS,12.05,"I"))
+21 IF XX'=0
SET LN=LN+1
DO SET^IBCNES1(LN,COL1,"Service Rank",$PIECE($GET(^IBE(365.042,XX,0)),U,2))
+22 SET XX=$GET(MIL(IBVF,IENS,12.04,"E"))
+23 IF XX'=""
SET LN=LN+1
DO SET^IBCNES1(LN,COL1,"Desc",XX)
+24 SET LN=LN+1
DO SET^IBCNES1(LN)
+25 QUIT
+26 ;
DFMT(MIL,IBVF,IENS) ; return proper date format string
+1 ;
+2 ; input - MIL = data array containing the data extracted from the military information fields (365, 12.01-12.07)
+3 ; IENS = ien of 365 entry or 2.312 entry
+4 ; output - RES = formatted date string
+5 NEW TODT,FROMDT,RES
+6 ; date range
+7 IF $GET(MIL(IBVF,IENS,12.06,"E"))="RD8"
SET FROMDT=$PIECE($GET(MIL(IBVF,IENS,12.07,"E")),"-")
SET TODT=$PIECE($GET(MIL(IBVF,IENS,12.07,"E")),"-",2)
SET RES=$$FMTE^XLFDT($$HL7TFM^XLFDT(FROMDT),2)_" - "_$$FMTE^XLFDT($$HL7TFM^XLFDT(TODT),2)
+8 ; single date
IF '$TEST
SET RES=$$FMTE^XLFDT($$HL7TFM^XLFDT($GET(MIL(IBVF,IENS,12.07,"E"))),2)
+9 QUIT RES
+10 ;
SET(LN,DATA,COL) ;set display data in scratch global
+1 NEW STR
+2 SET STR=""
+3 ; insert new data
SET STR=$$SETSTR^VALM1(DATA,STR,+COL,(81-COL))
+4 ; set the new data back into the scratch global
SET @DSP@(LN,0)=STR
+5 QUIT
+6 ;
