IBCNERP2 ;DAOU/BHS - IBCNE eIV RESPONSE REPORT COMPILE ; 03-JUN-2002
;;2.0;INTEGRATED BILLING;**184,271,416,528,659,702**;21-MAR-94;Build 53
;;Per VA Directive 6402, this routine should not be modified.
;
; Input vars from IBCNERP1:
; IBCNERTN="IBCNERP1"
; IBCNESPC("BEGDT")=Start Dt for rpt
; IBCNESPC("ENDDT")=End Dt for rpt
; IBCNESPC("PYR")=Pyr IEN for rpt. If "", then show all.
; IBCNESPC("PAT")=Pt IEN for rpt. If "", then show all.
; IBCNESPC("TYPE")=A (All Responses) for date range OR M (Most Recent
; Responses) for date range (by unique Pyr/Pt pair)
; IBCNESPC("SORT")=1 (Pyr nm) OR 2 (Pt nm)
; IBCNESPC("TRCN")=Trace #^IEN, if non-null, all other params are null
; IBCNESPC("RFLAG")=Report Flag used to indicate which report is being
; run. Response Report (0), Inactive Report (1), or Ambiguous
; Report (2).
; IBCNESPC("DTEXP")=Expiration date used in the inactive policy report
; IBOUT="R" for Report format or "E" for Excel format
;
; Output vars used by IBCNERP3:
; Structure of ^TMP based on eIV Response File (#365)
; IBCNERTN="IBCNERP1"
; SORT1=PyrNm (SORT=1) or PtNm(SORT=2)
; SORT2=PtNm (SORT=1) or PyrNm (SORT=2)
; ^TMP($J,IBCNERTN,SORT1,SORT2,CNT,0/1) based on ^IBCN(365,DA,0/1)
; CNT=Seq ct
; ^TMP($J,IBCNERTN,SORT1,SORT2,2,EBCT) based on ^IBCN(365,DA,2,EBCT,0)
; EBCT = Elig/Benefit multiple field IEN (ptr to 365.02)
; ^TMP($J,IBCNERTN,SORT1,SORT2,2,EBCT,NTCT) based on
; ^IBCN(365,DA,2,EB,0,NT,0) Notes for EB seg
; NTCT = Notes Ct may not equal Notes IEN (365.22) if ln must wrap
; ^TMP($J,IBCNERTN,SORT1,SORT2,3,CNCT) based on ^IBCN(365,DA,3,CNCT,0)
; CNCT = Contact Person multiple field IEN (ptr to 365.03)
; ^TMP($J,IBCNERTN,SORT1,SORT2,4,CT) based on ^IBCN(365,DA,4)
; CT=1 if len of text <=70, else ln is split
; ^TMP($J,IBCNERTN,SORT1,SORT2,5,CT) based on # lns of comments reqd
; CT=1 to display future retransmission date
;
; Must call at EN
Q
;
;
EN(IBCNERTN,IBCNESPC,IBOUT) ; Entry
; Init
N IBDT,IBBDT,IBPY,IBPYR,IBPT
N IBPAT,IBPTR,SORT1,SORT2,RPTDATA,IBTOT
N PYRIEN,PATIEN,IBTRC,IBTYP,IBCT,IBSRT,IBEXP,FRST,TQN,DONTINC,IPRF
;
I '$D(ZTQUEUED),$G(IOST)["C-",$G(IBOUT)="R" W !!,"Compiling report data ..."
;
; Temp ct
S (IBTOT,IBCT)=0
;
; Kill scratch globals
K ^TMP($J,IBCNERTN),^TMP($J,IBCNERTN_"X")
;
S IBTRC=$G(IBCNESPC("TRCN"))
; Skip for TRACE#
I IBTRC'="" G TRCN
;
S IBBDT=IBCNESPC("BEGDT")
S IBPY=$G(IBCNESPC("PYR"))
S IBPT=$G(IBCNESPC("PAT"))
S IBTYP=$G(IBCNESPC("TYPE"))
S IBSRT=$G(IBCNESPC("SORT"))
S IBEXP=$G(IBCNESPC("DTEXP"))
S IPRF=$G(IBCNESPC("RFLAG"))
;
; Loop thru the eIV Response File (#365) by Date/Time Response Rec X-Ref
; S IBDT=$O(^IBCN(365,"AD",IBCNESPC("ENDDT")))
; Initialize IBDT to end date
S IBDT=IBCNESPC("ENDDT")_".999999"
F S IBDT=$O(^IBCN(365,"AD",IBDT),-1) Q:IBDT=""!($P(IBDT,".",1)<IBBDT) D Q:$G(ZTSTOP)
. S PYRIEN=$S(IBPY="":0,1:$O(^IBCN(365,"AD",IBDT,IBPY),-1))
. F S PYRIEN=$O(^IBCN(365,"AD",IBDT,PYRIEN)) Q:'PYRIEN!((IBPY'="")&(PYRIEN'=IBPY)) D Q:$G(ZTSTOP)
.. I $D(ZTQUEUED),$$S^%ZTLOAD() S ZTSTOP=1 Q
.. ; Pyr nm from Pyr File (#365.12)
.. S IBPYR=$P($G(^IBE(365.12,PYRIEN,0)),U)
.. I IBPYR="" Q
.. S PATIEN=$S(IBPT="":0,1:$O(^IBCN(365,"AD",IBDT,PYRIEN,IBPT),-1))
.. F S PATIEN=$O(^IBCN(365,"AD",IBDT,PYRIEN,PATIEN)) Q:'PATIEN!((IBPT'="")&(PATIEN'=IBPT)) D Q:$G(ZTSTOP)
... ; Pt nm from Pt File (#2)
... S IBPAT=$P($G(^DPT(PATIEN,0)),U)
... I IBPAT="" Q
... S IBPTR=0
... F S IBPTR=$O(^IBCN(365,"AD",IBDT,PYRIEN,PATIEN,IBPTR)) Q:'IBPTR D Q:$G(ZTSTOP)
.... S IBTOT=IBTOT+1
.... ; Since non-positive identifications are no longer placed in the
.... ; insurance buffer, two new reports were added to allow users to
.... ; view the responses. One report (IPFR=1) shows only responses
.... ; of inactive policies. The other (IPFR=2) shows ambiguous responses.
.... ; Any response that is not active nor inactive is considered
.... ; ambiguous for the purposes of this report.
.... I IPRF D Q:DONTINC
..... N EBIC,NODE1,PCD
..... S DONTINC=1
..... S TQN=$P($G(^IBCN(365,IBPTR,0)),U,5) Q:TQN="" ; TQ ien (#365.1)
..... S NODE1=$G(^IBCN(365,IBPTR,1))
..... ; IB*702/DTG start only accept verified and remove policy exp date
..... ;I $P($G(^IBCN(365.1,TQN,0)),U,11)="V" Q ; If verification quit
..... I $P($G(^IBCN(365.1,TQN,0)),U,11)'="V" Q
..... ; I IPRF=1,($P(NODE1,U,12)="")!($P(NODE1,U,12)<$G(IBEXP)) Q
..... ; IB*702/DTG end only accept verified and remove policy exp date
..... S FRST=$O(^IBCN(365,IBPTR,2,0))
..... I FRST="" Q
..... S PCD=$P($G(^IBCN(365,IBPTR,2,FRST,0)),U,6)
..... I PCD]"",PCD'="eIV Eligibility Determination" Q
..... S EBIC=$$GET1^DIQ(365.02,FRST_","_IBPTR_",","ELIGIBILITY/BENEFIT INFO:CODE")
..... I PCD]"",IPRF=1,EBIC'=6 Q
..... ; IB*702/DTG start ambiguous
..... ;I PCD]"",IPRF=2,EBIC=6!(EBIC=1) Q
..... I PCD]"",IPRF=2,EBIC'="V" Q
..... ; IB*702/DTG end ambiguous
..... I $P(NODE1,U,14)]"" Q ; Error Condition
..... I $P(NODE1,U,15)]"" Q ; Error Action
..... I $P($G(^IBCN(365,IBPTR,4)),U)]"" Q ; Error Text
..... S DONTINC=0
....;
.... I $D(ZTQUEUED),IBTOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
.... ; Sort fields
.... S SORT1=$S(IBSRT=1:IBPYR,1:IBPAT)
.... S SORT2=$S(IBSRT=1:IBPAT,1:IBPYR)
.... ; Only check for Most Recent - Pyr/Pt pair
.... I IBTYP="M",$D(^TMP($J,IBCNERTN_"X",PYRIEN,PATIEN)) Q
.... ; Set temp ind.
.... I IBTYP="M" S ^TMP($J,IBCNERTN_"X",PYRIEN,PATIEN)=""
.... ; Update ct
.... S IBCT=IBCT+1
.... ; Sort data - build RPTDATA array
.... K RPTDATA
.... D GETDATA^IBCNERPE(IBPTR,.RPTDATA)
.... ; Merge data from RPTDATA to ^TMP
.... M ^TMP($J,IBCNERTN,SORT1,SORT2,IBCT)=RPTDATA
.... ;IB*2.0*659/TAZ - Store Response File IEN for later use
.... S ^TMP($J,IBCNERTN,SORT1,SORT2,IBCT,"RSPIENS")=IBPTR
;
; Purge index of duplicate Pyr/Pt combos
K ^TMP($J,IBCNERTN_"X")
;
G EXIT
;
TRCN ; Trace # proc.
S IBPTR=$P(IBTRC,U,2)
I IBPTR="" G EXIT
; Sort the data - build RPTDATA array
KILL RPTDATA
D GETDATA^IBCNERPE(IBPTR,.RPTDATA)
; Default sort - one record
; Pyr nm from Pyr File (#365.12)
S PYRIEN=$P(RPTDATA(0),U,3)
I PYRIEN="" G EXIT
S SORT1=$P($G(^IBE(365.12,PYRIEN,0)),U,1)
I SORT1="" G EXIT
; Pt nm from Pt File (#2)
S PATIEN=$P(RPTDATA(0),U,2)
I PATIEN="" G EXIT
S SORT2=$P($G(^DPT(PATIEN,0)),U,1)
I SORT2="" G EXIT
; Merge data- RPTDATA to ^TMP
M ^TMP($J,IBCNERTN,SORT1,SORT2,1)=RPTDATA
;IB*2.0*659/TAZ - Store Response File IEN for later use
S ^TMP($J,IBCNERTN,SORT1,SORT2,1,"RSPIENS")=IBPTR
;
EXIT ;
Q
;
X12(FILE,CODE,FLD) ; Output based on File # and X12 code
I $G(FILE)=""!($G(CODE)="") Q ""
; Quit w/o label if not defined in File Def.
Q $$LBL(365.02,$G(FLD))_$P($G(^IBE(FILE,CODE,0)),U,2) ;
LBL(FILE,FLD) ; Determine label from File Def.
N IBLBL
;
I $G(FILE)=""!($G(FLD)="") Q ""
S IBLBL=$$GET1^DID(FILE,FLD,"","TITLE")
Q $S(IBLBL'="":IBLBL_": ",1:"")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNERP2 7106 printed Apr 09, 2024@21:10:19 Page 2
IBCNERP2 ;DAOU/BHS - IBCNE eIV RESPONSE REPORT COMPILE ; 03-JUN-2002
+1 ;;2.0;INTEGRATED BILLING;**184,271,416,528,659,702**;21-MAR-94;Build 53
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Input vars from IBCNERP1:
+5 ; IBCNERTN="IBCNERP1"
+6 ; IBCNESPC("BEGDT")=Start Dt for rpt
+7 ; IBCNESPC("ENDDT")=End Dt for rpt
+8 ; IBCNESPC("PYR")=Pyr IEN for rpt. If "", then show all.
+9 ; IBCNESPC("PAT")=Pt IEN for rpt. If "", then show all.
+10 ; IBCNESPC("TYPE")=A (All Responses) for date range OR M (Most Recent
+11 ; Responses) for date range (by unique Pyr/Pt pair)
+12 ; IBCNESPC("SORT")=1 (Pyr nm) OR 2 (Pt nm)
+13 ; IBCNESPC("TRCN")=Trace #^IEN, if non-null, all other params are null
+14 ; IBCNESPC("RFLAG")=Report Flag used to indicate which report is being
+15 ; run. Response Report (0), Inactive Report (1), or Ambiguous
+16 ; Report (2).
+17 ; IBCNESPC("DTEXP")=Expiration date used in the inactive policy report
+18 ; IBOUT="R" for Report format or "E" for Excel format
+19 ;
+20 ; Output vars used by IBCNERP3:
+21 ; Structure of ^TMP based on eIV Response File (#365)
+22 ; IBCNERTN="IBCNERP1"
+23 ; SORT1=PyrNm (SORT=1) or PtNm(SORT=2)
+24 ; SORT2=PtNm (SORT=1) or PyrNm (SORT=2)
+25 ; ^TMP($J,IBCNERTN,SORT1,SORT2,CNT,0/1) based on ^IBCN(365,DA,0/1)
+26 ; CNT=Seq ct
+27 ; ^TMP($J,IBCNERTN,SORT1,SORT2,2,EBCT) based on ^IBCN(365,DA,2,EBCT,0)
+28 ; EBCT = Elig/Benefit multiple field IEN (ptr to 365.02)
+29 ; ^TMP($J,IBCNERTN,SORT1,SORT2,2,EBCT,NTCT) based on
+30 ; ^IBCN(365,DA,2,EB,0,NT,0) Notes for EB seg
+31 ; NTCT = Notes Ct may not equal Notes IEN (365.22) if ln must wrap
+32 ; ^TMP($J,IBCNERTN,SORT1,SORT2,3,CNCT) based on ^IBCN(365,DA,3,CNCT,0)
+33 ; CNCT = Contact Person multiple field IEN (ptr to 365.03)
+34 ; ^TMP($J,IBCNERTN,SORT1,SORT2,4,CT) based on ^IBCN(365,DA,4)
+35 ; CT=1 if len of text <=70, else ln is split
+36 ; ^TMP($J,IBCNERTN,SORT1,SORT2,5,CT) based on # lns of comments reqd
+37 ; CT=1 to display future retransmission date
+38 ;
+39 ; Must call at EN
+40 QUIT
+41 ;
+42 ;
EN(IBCNERTN,IBCNESPC,IBOUT) ; Entry
+1 ; Init
+2 NEW IBDT,IBBDT,IBPY,IBPYR,IBPT
+3 NEW IBPAT,IBPTR,SORT1,SORT2,RPTDATA,IBTOT
+4 NEW PYRIEN,PATIEN,IBTRC,IBTYP,IBCT,IBSRT,IBEXP,FRST,TQN,DONTINC,IPRF
+5 ;
+6 IF '$DATA(ZTQUEUED)
IF $GET(IOST)["C-"
IF $GET(IBOUT)="R"
WRITE !!,"Compiling report data ..."
+7 ;
+8 ; Temp ct
+9 SET (IBTOT,IBCT)=0
+10 ;
+11 ; Kill scratch globals
+12 KILL ^TMP($JOB,IBCNERTN),^TMP($JOB,IBCNERTN_"X")
+13 ;
+14 SET IBTRC=$GET(IBCNESPC("TRCN"))
+15 ; Skip for TRACE#
+16 IF IBTRC'=""
GOTO TRCN
+17 ;
+18 SET IBBDT=IBCNESPC("BEGDT")
+19 SET IBPY=$GET(IBCNESPC("PYR"))
+20 SET IBPT=$GET(IBCNESPC("PAT"))
+21 SET IBTYP=$GET(IBCNESPC("TYPE"))
+22 SET IBSRT=$GET(IBCNESPC("SORT"))
+23 SET IBEXP=$GET(IBCNESPC("DTEXP"))
+24 SET IPRF=$GET(IBCNESPC("RFLAG"))
+25 ;
+26 ; Loop thru the eIV Response File (#365) by Date/Time Response Rec X-Ref
+27 ; S IBDT=$O(^IBCN(365,"AD",IBCNESPC("ENDDT")))
+28 ; Initialize IBDT to end date
+29 SET IBDT=IBCNESPC("ENDDT")_".999999"
+30 FOR
SET IBDT=$ORDER(^IBCN(365,"AD",IBDT),-1)
if IBDT=""!($PIECE(IBDT,".",1)<IBBDT)
QUIT
Begin DoDot:1
+31 SET PYRIEN=$SELECT(IBPY="":0,1:$ORDER(^IBCN(365,"AD",IBDT,IBPY),-1))
+32 FOR
SET PYRIEN=$ORDER(^IBCN(365,"AD",IBDT,PYRIEN))
if 'PYRIEN!((IBPY'="")&(PYRIEN'=IBPY))
QUIT
Begin DoDot:2
+33 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+34 ; Pyr nm from Pyr File (#365.12)
+35 SET IBPYR=$PIECE($GET(^IBE(365.12,PYRIEN,0)),U)
+36 IF IBPYR=""
QUIT
+37 SET PATIEN=$SELECT(IBPT="":0,1:$ORDER(^IBCN(365,"AD",IBDT,PYRIEN,IBPT),-1))
+38 FOR
SET PATIEN=$ORDER(^IBCN(365,"AD",IBDT,PYRIEN,PATIEN))
if 'PATIEN!((IBPT'="")&(PATIEN'=IBPT))
QUIT
Begin DoDot:3
+39 ; Pt nm from Pt File (#2)
+40 SET IBPAT=$PIECE($GET(^DPT(PATIEN,0)),U)
+41 IF IBPAT=""
QUIT
+42 SET IBPTR=0
+43 FOR
SET IBPTR=$ORDER(^IBCN(365,"AD",IBDT,PYRIEN,PATIEN,IBPTR))
if 'IBPTR
QUIT
Begin DoDot:4
+44 SET IBTOT=IBTOT+1
+45 ; Since non-positive identifications are no longer placed in the
+46 ; insurance buffer, two new reports were added to allow users to
+47 ; view the responses. One report (IPFR=1) shows only responses
+48 ; of inactive policies. The other (IPFR=2) shows ambiguous responses.
+49 ; Any response that is not active nor inactive is considered
+50 ; ambiguous for the purposes of this report.
+51 IF IPRF
Begin DoDot:5
+52 NEW EBIC,NODE1,PCD
+53 SET DONTINC=1
+54 ; TQ ien (#365.1)
SET TQN=$PIECE($GET(^IBCN(365,IBPTR,0)),U,5)
if TQN=""
QUIT
+55 SET NODE1=$GET(^IBCN(365,IBPTR,1))
+56 ; IB*702/DTG start only accept verified and remove policy exp date
+57 ;I $P($G(^IBCN(365.1,TQN,0)),U,11)="V" Q ; If verification quit
+58 IF $PIECE($GET(^IBCN(365.1,TQN,0)),U,11)'="V"
QUIT
+59 ; I IPRF=1,($P(NODE1,U,12)="")!($P(NODE1,U,12)<$G(IBEXP)) Q
+60 ; IB*702/DTG end only accept verified and remove policy exp date
+61 SET FRST=$ORDER(^IBCN(365,IBPTR,2,0))
+62 IF FRST=""
QUIT
+63 SET PCD=$PIECE($GET(^IBCN(365,IBPTR,2,FRST,0)),U,6)
+64 IF PCD]""
IF PCD'="eIV Eligibility Determination"
QUIT
+65 SET EBIC=$$GET1^DIQ(365.02,FRST_","_IBPTR_",","ELIGIBILITY/BENEFIT INFO:CODE")
+66 IF PCD]""
IF IPRF=1
IF EBIC'=6
QUIT
+67 ; IB*702/DTG start ambiguous
+68 ;I PCD]"",IPRF=2,EBIC=6!(EBIC=1) Q
+69 IF PCD]""
IF IPRF=2
IF EBIC'="V"
QUIT
+70 ; IB*702/DTG end ambiguous
+71 ; Error Condition
IF $PIECE(NODE1,U,14)]""
QUIT
+72 ; Error Action
IF $PIECE(NODE1,U,15)]""
QUIT
+73 ; Error Text
IF $PIECE($GET(^IBCN(365,IBPTR,4)),U)]""
QUIT
+74 SET DONTINC=0
End DoDot:5
if DONTINC
QUIT
+75 ;
+76 IF $DATA(ZTQUEUED)
IF IBTOT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+77 ; Sort fields
+78 SET SORT1=$SELECT(IBSRT=1:IBPYR,1:IBPAT)
+79 SET SORT2=$SELECT(IBSRT=1:IBPAT,1:IBPYR)
+80 ; Only check for Most Recent - Pyr/Pt pair
+81 IF IBTYP="M"
IF $DATA(^TMP($JOB,IBCNERTN_"X",PYRIEN,PATIEN))
QUIT
+82 ; Set temp ind.
+83 IF IBTYP="M"
SET ^TMP($JOB,IBCNERTN_"X",PYRIEN,PATIEN)=""
+84 ; Update ct
+85 SET IBCT=IBCT+1
+86 ; Sort data - build RPTDATA array
+87 KILL RPTDATA
+88 DO GETDATA^IBCNERPE(IBPTR,.RPTDATA)
+89 ; Merge data from RPTDATA to ^TMP
+90 MERGE ^TMP($JOB,IBCNERTN,SORT1,SORT2,IBCT)=RPTDATA
+91 ;IB*2.0*659/TAZ - Store Response File IEN for later use
+92 SET ^TMP($JOB,IBCNERTN,SORT1,SORT2,IBCT,"RSPIENS")=IBPTR
End DoDot:4
if $GET(ZTSTOP)
QUIT
End DoDot:3
if $GET(ZTSTOP)
QUIT
End DoDot:2
if $GET(ZTSTOP)
QUIT
End DoDot:1
if $GET(ZTSTOP)
QUIT
+93 ;
+94 ; Purge index of duplicate Pyr/Pt combos
+95 KILL ^TMP($JOB,IBCNERTN_"X")
+96 ;
+97 GOTO EXIT
+98 ;
TRCN ; Trace # proc.
+1 SET IBPTR=$PIECE(IBTRC,U,2)
+2 IF IBPTR=""
GOTO EXIT
+3 ; Sort the data - build RPTDATA array
+4 KILL RPTDATA
+5 DO GETDATA^IBCNERPE(IBPTR,.RPTDATA)
+6 ; Default sort - one record
+7 ; Pyr nm from Pyr File (#365.12)
+8 SET PYRIEN=$PIECE(RPTDATA(0),U,3)
+9 IF PYRIEN=""
GOTO EXIT
+10 SET SORT1=$PIECE($GET(^IBE(365.12,PYRIEN,0)),U,1)
+11 IF SORT1=""
GOTO EXIT
+12 ; Pt nm from Pt File (#2)
+13 SET PATIEN=$PIECE(RPTDATA(0),U,2)
+14 IF PATIEN=""
GOTO EXIT
+15 SET SORT2=$PIECE($GET(^DPT(PATIEN,0)),U,1)
+16 IF SORT2=""
GOTO EXIT
+17 ; Merge data- RPTDATA to ^TMP
+18 MERGE ^TMP($JOB,IBCNERTN,SORT1,SORT2,1)=RPTDATA
+19 ;IB*2.0*659/TAZ - Store Response File IEN for later use
+20 SET ^TMP($JOB,IBCNERTN,SORT1,SORT2,1,"RSPIENS")=IBPTR
+21 ;
EXIT ;
+1 QUIT
+2 ;
X12(FILE,CODE,FLD) ; Output based on File # and X12 code
+1 IF $GET(FILE)=""!($GET(CODE)="")
QUIT ""
+2 ; Quit w/o label if not defined in File Def.
+3 ;
QUIT $$LBL(365.02,$GET(FLD))_$PIECE($GET(^IBE(FILE,CODE,0)),U,2)
LBL(FILE,FLD) ; Determine label from File Def.
+1 NEW IBLBL
+2 ;
+3 IF $GET(FILE)=""!($GET(FLD)="")
QUIT ""
+4 SET IBLBL=$$GET1^DID(FILE,FLD,"","TITLE")
+5 QUIT $SELECT(IBLBL'="":IBLBL_": ",1:"")
+6 ;
