IBCNERPC ;DAOU/RO - PAYER LINK REPORT - Compile & Print;AUG-2003
;;2.0;INTEGRATED BILLING;**184,252,271,416,528,668,687,737,752**;21-MAR-94;Build 20
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to EN^XUTMDEVQ in ICR #1519
;
; IB*2*687-rewrote/redesigned the report (basically from scratch) which
; included combining 3 routines into 2. The changes based on the patches prior
; to IB*2*688 were not tracked in the routine in the past; therefore, you will
; not find references to them below. The IB*2*668 reference (translating "IIV"
; to "EIV") will be overwritten with the rewrite.
;
; eIV - Electronic Ins. Verification
; IIU - Interfacility Ins. Update
;
; Input parameters: N/A
; Variables ZTSAVED for queueing:
; IBCNERTN="IBCNERPB" (current routine)
; IBCNESPC("PAPP")=Payer APPLICATION selected (1-eIV, 2-IIU, 3-Both)
; IBCNESPC("PDEACT")=Included Deactivated Payers? (1-include, 2-exclude)
; IBCNESPC("PDET")=Include Ins detail? (1-include list of ins, 2-do not list)
; IBCNESPC("POUT")=Output Format ('E'=EXCEL, 'R'=REPORT)
; IBCNESPC("PPYR")=Single Payer name or "" for ALL
; IBCNESPC("PSORT")=Primary Sort
; IBCNESPC("PTYPE")=Payer type (1-no active ins linked, 2-at least 1 ins linked, 3-All Payers)
Q
;
COMPILE(IBCNERTN,IBCNESPC) ; Entry point called from EN^XUTMDEVQ.
; IBCNERTN = Routine name for ^TMP($J,...
; IBCNESPC = Array of params
N PAPP,PDEACT,PDET,POUT,PPYR,PSORT,PTYPE
; IB*2*687/DTG start print msg in rept if no data for APP
N IBII,IBIJ,IBAPP
; IB*2*687/DTG end print msg in rept if no data for APP
S PAPP=$G(IBCNESPC("PAPP")) ; Payer Application (1=eIV, 2=IIU, 3=Both)
S PDEACT=$G(IBCNESPC("PDEACT")) ; Deactivated Payers? (1=include, 0=exclude)
S PDET=$G(IBCNESPC("PDET")) ; Ins detail? (1=include list of ins, 2=do not list)
S POUT=$G(IBCNESPC("POUT")) ; Output Format ('E'=EXCEL, 'R'=Report)
S PPYR=$G(IBCNESPC("PPYR")) ; Single Payer name or "" for ALL
S PSORT=$G(IBCNESPC("PSORT")) ; Primary Sort
S PTYPE=$G(IBCNESPC("PTYPE")) ; Payer Type (1=no active ins linked, 2=at least 1 ins linked, 3=All Payers)
K ^TMP($J,IBCNERTN)
D GETDATA
D PRINT
;
COMPILEX ; COMPILE exit
K ^TMP($J,IBCNERTN)
D ^%ZISC
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
GETDATA ; Compile the data.
;IB*737/TAZ - Removed reference to Most Popular Payer and "~NO PAYER"
N IBPY,IBPYR
K ^TMP($J,IBCNERTN)
; IB*2*687/DTG start print msg in rept if no data for APP
; Create stub for EIV and IIU in TMP file for validation
I PAPP=""!(PAPP=1)!(PAPP=3) S ^TMP($J,IBCNERTN,"PAYER","EIV")=""
I PAPP=2!(PAPP=3) S ^TMP($J,IBCNERTN,"PAYER","IIU")=""
; IB*2*687/DTG end print msg in rept if no data for APP
I '$D(ZTQUEUED),$G(IOST)["C-",POUT="R" W !!,"Compiling report data ..."
;
; SINGLE PAYER
I PPYR'="" D Q
. S IBPY=+PPYR ; Internal Payer ID number
. S IBPYR=$P(PPYR,U,2) ; Payer's Name
. D GETDATA1 ; Get the current payer's data
. Q
;
; ALL PAYERS (Loop thru #365.12)
S IBPY=0
F S IBPY=$O(^IBE(365.12,IBPY)) Q:'IBPY D Q:$G(ZTSTOP)
. I '+PDEACT,+$$PYRDEACT^IBCNINSU(+IBPY) Q ; Don't want DEACTIVATED Payers
. S IBPYR=$$GET1^DIQ(365.12,IBPY,.01) ; Payer name from (#365.12)
. I ($$PYRAPP^IBCNEUT5("EIV",IBPY)="")&($$PYRAPP^IBCNEUT5("IIU",IBPY)="") Q ; Only accept eIV & IIU Payers
. D GETDATA1
Q
;
GETDATA1 ; Process the current payer.
N ALSOEIV,ALSOIIU,APPEIV,APPIIU,AUTUPD,EDIINST,EDIPROF,IBCT,IBEIVIEN,IBIIUIEN,IBINS,IBINSN,INSDATA
N LOCENB,NATENB,NOLNKCOS,PAPPARY,PEINEIV,PEINIIU,RCVIIU,STATECD,VAID
S APPEIV=$$FIND1^DIC(365.13,,,"EIV"),APPIIU=$$FIND1^DIC(365.13,,,"IIU")
D PAYER^IBCNINSU(IBPY,"","**","E",.PAPPARY) ; Obtain all the Payer and Payer Application data
S (PEINEIV,PEINIIU)=""
S IBEIVIEN=$$PYRAPP^IBCNEUT5("EIV",IBPY),IBIIUIEN=$$PYRAPP^IBCNEUT5("IIU",IBPY)
I IBEIVIEN S PEINEIV="EIV"_U_IBEIVIEN_","_IBPY_"," ; EIV App
I IBIIUIEN S PEINIIU="IIU"_U_IBIIUIEN_","_IBPY_"," ; IIU App
;
I PAPP=1,PEINEIV="" Q ; Only want eIV Payers and this Payer doesn't have an eIV app.
I PAPP=2,PEINIIU="" Q ; Only want IIU Payers and this Payer doesn't have an IIU app.
;
S VAID=$G(PAPPARY(365.12,IBPY_",",.02,"E")) ; VA Nat'l Payer ID
S EDIINST=$G(PAPPARY(365.12,IBPY_",",.06,"E")),EDIPROF=$G(PAPPARY(365.12,IBPY_",",.05,"E")) ; Inst & Prof EDI #s
S ALSOEIV="NO" I PEINEIV'="" S ALSOEIV=$S($G(PAPPARY(365.121,$P(PEINEIV,U,2),.01,"E"))="EIV":"YES",1:"NO") ; eIV Also
S ALSOIIU="NO" I PEINIIU'="" S ALSOIIU=$S($G(PAPPARY(365.121,$P(PEINIIU,U,2),.01,"E"))="IIU":"YES",1:"NO") ; IIU Also
S AUTUPD="" I PEINEIV'="" S AUTUPD=$G(PAPPARY(365.121,$P(PEINEIV,U,2),4.01,"E")) ; Auto Update field for eIV
S RCVIIU="" I PEINIIU'="" S RCVIIU=$G(PAPPARY(365.121,$P(PEINIIU,U,2),5.01,"E")) ; Receive IIU Data field for IIU
S NATENB("EIV")="NO" I PEINEIV'="" S NATENB("EIV")=$S($G(PAPPARY(365.121,$P(PEINEIV,U,2),.02,"E"))="Enabled":"YES",1:"NO") ; Nat'l Enabled Status for eIV
S NATENB("IIU")="NO" I PEINIIU'="" S NATENB("IIU")=$S($G(PAPPARY(365.121,$P(PEINIIU,U,2),.02,"E"))="Enabled":"YES",1:"NO") ; Nat'l Enabled Status for IIU
S LOCENB("EIV")="NO" I PEINEIV'="" S LOCENB("EIV")=$S($G(PAPPARY(365.121,$P(PEINEIV,U,2),.03,"E"))="Enabled":"YES",1:"NO") ; Locally Enabled Status for eIV
S LOCENB("IIU")="NO" I PEINIIU'="" S LOCENB("IIU")=$S($G(PAPPARY(365.121,$P(PEINIIU,U,2),.03,"E"))="Enabled":"YES",1:"NO") ; Locally Enabled Status for IIU
;
; Get # of linked ins carriers for payer
S IBCT=0,IBINS=""
I PTYPE=1,$D(^DIC(36,"AC",IBPY)) Q ; Unlinked report-Only want payers without linked ins cos.
I PTYPE=2,'$D(^DIC(36,"AC",IBPY)) Q ; Linked report-Only want payers with linked ins cos.
F S IBINS=$O(^DIC(36,"AC",IBPY,IBINS)) Q:IBINS="" D
. S IBINSN=$G(^DIC(36,IBINS,0)),IBINSN=$P(IBINSN,U) Q:IBINSN=""
. S IBCT=IBCT+1
. ;If ins detail requested, save address & EDI#'s
. I PDET=1 D
. . S STATECD=$$GET1^DIQ(36,IBINS,.115,"I")
. . S INSDATA=$$GET1^DIQ(36,IBINS,.111)_U_$$GET1^DIQ(36,IBINS,.114)_U_$P($G(^DIC(5,+STATECD,0)),U,2)_U_$$GET1^DIQ(36,IBINS,.116,"E")
. . S INSDATA=INSDATA_U_$$GET1^DIQ(36,IBINS,3.02)_U_$$GET1^DIQ(36,IBINS,3.04)
. . S ^TMP($J,IBCNERTN,"INSDTL",IBPY,IBINSN,IBINS)=INSDATA
;
SORTIT ; Set SORT params...use the negative of IBCT to sort in reverse order.
I PSORT=1 D ; SORT by Payer Name
. S SORT1=IBPYR,SORT2=VAID,SORT5=-IBCT
. I PEINEIV'="","^1^3^"[(U_PAPP_U) D ; For eIV or Both report
. . S SORT3=NATENB("EIV"),SORT4=LOCENB("EIV")
. . D SAVDATA("EIV")
. I PEINIIU'="","^2^3^"[(U_PAPP_U) D ; For IIU or Both report
. . S SORT3=NATENB("IIU"),SORT4=LOCENB("IIU")
. . D SAVDATA("IIU")
;
I PSORT=2 D ; SORT by VAID
. S SORT1=VAID,SORT2=IBPYR,SORT5=-IBCT
. I PEINEIV'="","^1^3^"[(U_PAPP_U) D ; For eIV or Both report
. . S SORT3=NATENB("EIV"),SORT4=LOCENB("EIV")
. . D SAVDATA("EIV")
. I PEINIIU'="","^2^3^"[(U_PAPP_U) D ; For IIU or Both report
. . S SORT3=NATENB("IIU"),SORT4=LOCENB("IIU")
. . D SAVDATA("IIU")
;
I PSORT=3 D ; SORT by Nat'l Enabled Status
. S SORT2=IBPYR,SORT3=VAID,SORT5=-IBCT
. I PEINEIV'="","^1^3^"[(U_PAPP_U) D ; For eIV or Both report
. . S SORT1=NATENB("EIV"),SORT4=LOCENB("EIV")
. . D SAVDATA("EIV")
. I PEINIIU'="","^2^3^"[(U_PAPP_U) D ; For IIU or Both report
. . S SORT1=NATENB("IIU"),SORT4=LOCENB("IIU")
. . D SAVDATA("IIU")
;
I PSORT=4 D ; SORT by Locally Enabled Status
. S SORT2=IBPYR,SORT3=VAID,SORT5=-IBCT
. I PEINEIV'="","^1^3^"[(U_PAPP_U) D ; For eIV or Both report
. . S SORT1=LOCENB("EIV"),SORT4=NATENB("EIV")
. . D SAVDATA("EIV")
. I PEINIIU'="","^2^3^"[(U_PAPP_U) D ; For IIU or Both report
. . S SORT1=LOCENB("IIU"),SORT4=NATENB("IIU")
. . D SAVDATA("IIU")
;
I PSORT=5 D ; SORT by # of ins cos
. S SORT1=-IBCT,SORT2=IBPYR,SORT3=VAID
. I PEINEIV'="","^1^3^"[(U_PAPP_U) D ; For eIV or Both report
. . S SORT4=NATENB("EIV"),SORT5=LOCENB("EIV")
. . D SAVDATA("EIV")
. I PEINIIU'="","^2^3^"[(U_PAPP_U) D ; For IIU or Both report
. . S SORT4=NATENB("IIU"),SORT5=LOCENB("IIU")
. . D SAVDATA("IIU")
Q
;
SAVDATA(APP) ; Save data to print
I POUT="R" D Q ; REPORT format
. S ^TMP($J,IBCNERTN,"PAYER",APP,SORT1,SORT2,SORT3,SORT4,SORT5)=IBPY_U_IBPYR_U_VAID_U_EDIPROF_U_EDIINST_U_$G(NATENB(APP))_U_$G(LOCENB(APP))_U_$S(APP="IIU":RCVIIU,1:$G(AUTUPD))_U_$S(APP="IIU":ALSOEIV,1:ALSOIIU)_U_IBCT
; EXCEL format - only want to report a payer once in EXCEL format.
I '$D(^TMP($J,IBCNERTN,"PAYER",SORT1)) S ^TMP($J,IBCNERTN,"PAYER",SORT1,SORT2,SORT3,SORT4,SORT5)=IBPY_U_IBPYR_U_VAID_U_EDIPROF_U_EDIINST_U_IBCT_U_$G(NATENB("EIV"))_U_LOCENB("EIV")_U_$G(AUTUPD)_U_NATENB("IIU")_U_LOCENB("IIU")_U_$G(RCVIIU)
Q
;
PRINT ;
N APP,CRT,DASHES,EORMSG,HDRDATE,HDRNAME,IBPGC,IBPXT,MAXCNT,NONEMSG,PREVAPP,SORT1,SORT2,SORT3,SORT4,SORT5,ZTSTOP,DIS
S EORMSG="*** END OF REPORT ***"
S NONEMSG="* * * N O D A T A F O U N D * * *"
S HDRNAME="Payer Link Report",HDRDATE=$$FMTE^XLFDT($$NOW^XLFDT,1)_" Page: "
S $P(DASHES,"-",131)="",(APP,SORT1,SORT2,SORT3,SORT4,SORT5)=""
S (IBPXT,IBPGC)=0
; IO params
I "^R^E^"'[(U_$G(POUT)_U) S POUT="R"
S MAXCNT=IOSL-3,CRT=1
I IOST'["C-" S MAXCNT=IOSL-6,CRT=0
D PRINT1 Q:(IBPXT!$G(ZTSTOP)) ; Print report
I CRT,IBPGC>0,'$D(ZTQUEUED) D
. I MAXCNT<51 F LIN=1:1:(MAXCNT-$Y) W !
. S DIR(0)="E" D ^DIR K DIR
I POUT="E",CRT,'$D(ZTQUEUED) S DIR(0)="E" D ^DIR K DIR ; End of the EXCEL Report
Q
;
PRINT1 ; Print report
S (APP,PREVAPP)=""
; EXCEL Format
I POUT="E" D G PRINT2
. D EHDR ; EXCEL Header
. I '$D(^TMP($J,IBCNERTN)) D Q
. . D HEADER(APP,HDRNAME,HDRDATE)
. . W !,?$$CENTER(NONEMSG,132),NONEMSG,!! Q ; Nothing to print.
. ;
. ; Process through the Sort array
. S SORT1="" F S SORT1=$O(^TMP($J,IBCNERTN,"PAYER",SORT1)) Q:SORT1="" D Q:(IBPXT!$G(ZTSTOP))
. . S SORT2="" F S SORT2=$O(^TMP($J,IBCNERTN,"PAYER",SORT1,SORT2)) Q:SORT2="" D Q:(IBPXT!$G(ZTSTOP))
. . . S SORT3="" F S SORT3=$O(^TMP($J,IBCNERTN,"PAYER",SORT1,SORT2,SORT3)) Q:SORT3="" D Q:(IBPXT!$G(ZTSTOP))
. . . . S SORT4="" F S SORT4=$O(^TMP($J,IBCNERTN,"PAYER",SORT1,SORT2,SORT3,SORT4)) Q:SORT4="" D Q:(IBPXT!$G(ZTSTOP))
. . . . . S SORT5="" F S SORT5=$O(^TMP($J,IBCNERTN,"PAYER",SORT1,SORT2,SORT3,SORT4,SORT5)) Q:SORT5="" D Q:(IBPXT!$G(ZTSTOP))
. . . . . . K DISPDATA ; Init disp
. . . . . . D DATA(.DISPDATA),LINE(.DISPDATA) ; build/display data
;
; REPORT Format
I '$D(^TMP($J,IBCNERTN)) D Q
. ; IB*2*687/DTG start print msg in rept if no data FOUND, make sure all APP's for report are covered
. S IBII=$S(PAPP=1:1,PAPP=2:2,PAPP=3:2,1:1)
. F IBIJ=1:1:IBII S IBAPP=$P("EIV,IIU",",",IBIJ) I PAPP=3!(IBIJ=1&(PAPP=1))!(IBIJ=2&(PAPP=2)) D ;<
. . D HEADER(IBAPP,HDRNAME,HDRDATE)
. . W !,?$$CENTER(NONEMSG,132),NONEMSG,!! Q ; Nothing to print.
. ; IB*2*687/DTG end print msg in rept if no data for APP
;
; Process through the Sort array
F S APP=$O(^TMP($J,IBCNERTN,"PAYER",APP)) Q:APP="" D Q:(IBPXT!$G(ZTSTOP))
. S PREVAPP=APP
. ; IB*2*687/DTG start print msg in rept if no data for APP
. ; added a DO layer in order to check if data for APP
. I POUT="R" D ;<
. . I $D(^TMP($J,IBCNERTN,"PAYER",APP))<10 D Q
. . . D HEADER(APP,HDRNAME,HDRDATE)
. . . W !,?$$CENTER(NONEMSG,132),NONEMSG,!!
. . ; print no data found if APP does not have data
. . D HEADER(APP,HDRNAME,HDRDATE) Q:(IBPXT!$G(ZTSTOP)) ; REPORT Header
. . S SORT1="" F S SORT1=$O(^TMP($J,IBCNERTN,"PAYER",APP,SORT1)) Q:SORT1="" D Q:(IBPXT!$G(ZTSTOP))
. . . S SORT2="" F S SORT2=$O(^TMP($J,IBCNERTN,"PAYER",APP,SORT1,SORT2)) Q:SORT2="" D Q:(IBPXT!$G(ZTSTOP))
. . . . S SORT3="" F S SORT3=$O(^TMP($J,IBCNERTN,"PAYER",APP,SORT1,SORT2,SORT3)) Q:SORT3="" D Q:(IBPXT!$G(ZTSTOP))
. . . . . S SORT4="" F S SORT4=$O(^TMP($J,IBCNERTN,"PAYER",APP,SORT1,SORT2,SORT3,SORT4)) Q:SORT4="" D Q:(IBPXT!$G(ZTSTOP))
. . . . . . S SORT5="" F S SORT5=$O(^TMP($J,IBCNERTN,"PAYER",APP,SORT1,SORT2,SORT3,SORT4,SORT5)) Q:SORT5="" D Q:(IBPXT!$G(ZTSTOP))
. . . . . . . K DISPDATA ; Init disp
. . . . . . . D DATA(.DISPDATA),LINE(.DISPDATA) ; build/display data
. ; IB*2*687/DTG end print msg in rept if no data for APP
;
PRINT2 ;
I IBPXT!$G(ZTSTOP) Q
;
I POUT="R" D Q:(IBPXT!$G(ZTSTOP))
. I $Y+1>MAXCNT!('IBPGC) D HEADER(PREVAPP,HDRNAME,HDRDATE)
W !,?$$CENTER(EORMSG,132),EORMSG
Q
;
N DIR,DTOUT,DUOUT,HDR,HDRDET,LIN,OFFSET1,OFFSET2,X,Y
I CRT,IBPGC>0,'$D(ZTQUEUED) D Q:IBPXT
. I MAXCNT<51 F LIN=1:1:(MAXCNT-$Y) W !
. S DIR(0)="E" D ^DIR K DIR
. I $D(DTOUT)!($D(DUOUT)) S IBPXT=1 Q
I $D(ZTQUEUED),$$S^%ZTLOAD() S ZTSTOP=1 Q
S IBPGC=IBPGC+1,HDRDATE=HDRDATE_+IBPGC,HDRDET=""
I PPYR="" S HDRDET="All "_$S(PTYPE=1:"Unlinked ",PTYPE=2:"Linked ",1:"")_APP_" Payers"
I PTYPE'=1 D
. I $L(HDRDET) S HDRDET=HDRDET_", "
. ; IB*2*687/DTG start change for space
. S HDRDET=HDRDET_$S(PDET=1:"With",1:"Without")_" Ins. Co. Detail"
. ; IB*2*687/DTG end change for space
S OFFSET1=$$CENTER(HDRDET,(132-$L(HDRNAME)))
S OFFSET2=131-$L(HDRDATE)
W @IOF,!,HDRNAME,?OFFSET1,HDRDET,?OFFSET2,HDRDATE
W !
I PPYR'="" W ?1,APP," Payer: ",$P(PPYR,"^",2)
;W !,?46,"# Linked",?63,"Nationally",?82,"Locally"
W !,?46,"# Linked",?63,$S(APP="IIU":"IIU",1:"EIV")," Nationally",?82,$S(APP="IIU":"IIU",1:"EIV")," Locally" ;IB*752/DTG to tell which is IIU and EIV
W ?98,$S(APP="IIU":"Receive",1:"Auto")
W ?113,"Prof/Inst.",?126,"Also"
; IB*2*687/DTG start remove ':' from payer name
W !,"Payer Name"
W ?32,"VA ID",?46,"Ins. Co.",?63,"Enabled",?82,"Enabled"
; IB*2*687/DTG end remove ':' from payer name
W ?98,$S(APP="IIU":"IIU Data",1:"Update")
W ?113,"EDI#",?126,$S(APP="EIV":"IIU",1:"EIV")
W !,DASHES
Q
;
; IB*2*687/DTG start change for space DISPDATA - DIS,RPTDATA - RPT,INCODATA - INCO,INSNAME - INSNA,INSREC - INSR
DATA(DIS) ; Build disp lines
N CITY,CSZ,CT,CT2,ELINE,INCO,INSNA,INSNO,INSR,LCT,PYRNO,RPT,SPACES,STZIP
; Merge into local array
S $P(SPACES," ",100)=" "
I POUT="E" M RPT=^TMP($J,IBCNERTN,"PAYER",SORT1,SORT2,SORT3,SORT4,SORT5)
I POUT="R" M RPT=^TMP($J,IBCNERTN,"PAYER",APP,SORT1,SORT2,SORT3,SORT4,SORT5)
M INCO=^TMP($J,IBCNERTN,"INSDTL",$P(RPT,U,1)) ; Ins Co Detail
;
; EXCEL format
I POUT="E" D Q
. N IBINSN,IBINS,IBPY,INSR,LCT,XX
. S IBPY=$P(RPT,U),ELINE=$P(RPT,U,2,12)
. I (PDET=2!'$D(^TMP($J,IBCNERTN,"INSDTL",IBPY))) S LCT=1,DIS(LCT)=ELINE Q
. ;Print Ins Co Detail
. S (IBINSN,IBINS,XX)="",LCT=0
. I $D(^TMP($J,IBCNERTN,"INSDTL",IBPY)) D Q
. . F S IBINSN=$O(^TMP($J,IBCNERTN,"INSDTL",IBPY,IBINSN)) Q:IBINSN="" D
. . . F S IBINS=$O(^TMP($J,IBCNERTN,"INSDTL",IBPY,IBINSN,IBINS)) Q:IBINS="" D
. . . . S INSR=^TMP($J,IBCNERTN,"INSDTL",IBPY,IBINSN,IBINS)
. . . . S LCT=LCT+1
. . . . S DIS(LCT)=ELINE_U_IBINSN_U_INSR
;
; Format 1st line (payer)
S LCT=1,DIS(LCT)=$$FO^IBCNEUT1($E($P(RPT,U,2),1,30),32,"L")_$$FO^IBCNEUT1($P(RPT,U,3),14,"L")_$$FO^IBCNEUT1($P(RPT,U,10),17,"L")
S DIS(LCT)=DIS(LCT)_$$FO^IBCNEUT1($P(RPT,U,6),19,"L")_$$FO^IBCNEUT1($P(RPT,U,7),16,"L")_$$FO^IBCNEUT1($P(RPT,U,8),15,"L")
I $P(RPT,U,4)'=""!($P(RPT,U,5)'="") S DIS(LCT)=DIS(LCT)_$$FO^IBCNEUT1($P(RPT,U,4),5,"R")_"/"_$$FO^IBCNEUT1($P(RPT,U,5),7,"L")
I $P(RPT,U,4)="",$P(RPT,U,5)="" S DIS(LCT)=DIS(LCT)_$E(SPACES,1,13) ; If nothing to print, substitute spaces.
S DIS(LCT)=DIS(LCT)_$$FO^IBCNEUT1($P(RPT,U,9),3,"L")
;
I PDET=1 D ; Format Ins Co detail
. I $O(INCO(""))'="" D
. . S LCT=LCT+1
. . S DIS(LCT)=" Linked Insurance Companies Address"_$E(SPACES,1,30)_"City, State, Zip code"
. . S (INSNA,INSNO,INSDATA)=""
. . F S INSNA=$O(INCO(INSNA)) Q:INSNA="" D
. . . F S INSNO=$O(INCO(INSNA,INSNO)) Q:INSNO="" D
. . . . S INSDATA=INCO(INSNA,INSNO)
. . . . S LCT=LCT+1,DIS(LCT)=" "_$$FO^IBCNEUT1(INSNA,33,"L")_$$FO^IBCNEUT1($P(INSDATA,U,1),37,"L")
. . . . S CITY=$P(INSDATA,U,2)
. . . . ; don't display ',' if no address/state on file
. . . . S STZIP=""
. . . . I $P(INSDATA,U,3)'="" S STZIP=", "_$P(INSDATA,U,3)
. . . . I $P(INSDATA,U,4)'="" S STZIP=STZIP_" "_$P(INSDATA,U,4)
. . . . S CSZ=$E(CITY,1,39-$L(STZIP))_STZIP
. . . . S DIS(LCT)=DIS(LCT)_$$FO^IBCNEUT1(CSZ,41,"L")
. . . . I $P(INSDATA,U,5)'=""!($P(INSDATA,U,6)'="") S DIS(LCT)=DIS(LCT)_$$FO^IBCNEUT1($P(INSDATA,U,5),5,"R")_"/"_$$FO^IBCNEUT1($P(INSDATA,U,6),7,"L")
. . . . I $P(RPT,U,5)="",$P(RPT,U,6)="" S DIS(LCT)=DIS(LCT)_$E(SPACES,1,13) ; If nothing to print, substitute spaces.
; IB*2*687/DTG end change for space DISPDATA - DIS,RPTDATA - RPT,INCODATA - INCO,INSNAME - INSNA,INSREC - INSR
S LCT=LCT+1
Q
;
EHDR ; EXCEL header
N HDR,X
S HDR="",X="Payer Link Report^"
W X
; IB*2*687/DTG start change for space
I PPYR="" S HDR=$S(PTYPE=1:"Unlinked",PTYPE=2:"Linked",1:"All")_" Payers"_"^"
; If not "unlinked" check for detail option.
I PTYPE'=1 S HDR=HDR_$S(PDET=1:"With",1:"Without")_" Ins. Co. Detail"_"^" W HDR
; IB*2*687/DTG end change for space
W $$FMTE^XLFDT($$NOW^XLFDT,1)
;
I PPYR'="" W !,"For Single Payer:"_"^"_$P(PPYR,"^",2)
;
S X="Payer Name^VA ID^Elig Prof EDI#^Elig Inst EDI#^# Linked Ins. Co.^eIV Natl Enabled^eIV Locally Enabled^eIV Auto Update^IIU Natl Enabled^IIU Locally Enabled^Receive IIU Data"
I PDET=1 S X=X_"^Company Name^St Address^City^ST^Zip^Claims Prof EDI#^Claims Inst EDI#"
W !,X
Q
Q
;
; IB*2*687/DTG start change for space
LINE(DIS) ; Print data
N LNCT,LNTOT,NWPG
S LNTOT=+$O(DIS(""),-1)
S NWPG=0
F LNCT=1:1:LNTOT D Q:(IBPXT!$G(ZTSTOP))
. I POUT="R" D Q:(IBPXT!$G(ZTSTOP))
. . I $Y+1>MAXCNT!('IBPGC) D HEADER(APP,HDRNAME,HDRDATE) S NWPG=1 I $G(ZTSTOP)!IBPXT Q
. W !,DIS(LNCT)
; IB*2*687/DTG end change for space
Q
LINEX Q
;
CENTER(LINE,XWIDTH) ;return centered line OFFSET
; IB*2*687/DTG start change for space
N LE,OF
S LE=$L(LINE),OF=XWIDTH-$L(LINE)\2
Q OF
; IB*2*687/DTG end change for space
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNERPC 18020 printed Apr 09, 2024@21:18:20 Page 2
IBCNERPC ;DAOU/RO - PAYER LINK REPORT - Compile & Print;AUG-2003
+1 ;;2.0;INTEGRATED BILLING;**184,252,271,416,528,668,687,737,752**;21-MAR-94;Build 20
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to EN^XUTMDEVQ in ICR #1519
+5 ;
+6 ; IB*2*687-rewrote/redesigned the report (basically from scratch) which
+7 ; included combining 3 routines into 2. The changes based on the patches prior
+8 ; to IB*2*688 were not tracked in the routine in the past; therefore, you will
+9 ; not find references to them below. The IB*2*668 reference (translating "IIV"
+10 ; to "EIV") will be overwritten with the rewrite.
+11 ;
+12 ; eIV - Electronic Ins. Verification
+13 ; IIU - Interfacility Ins. Update
+14 ;
+15 ; Input parameters: N/A
+16 ; Variables ZTSAVED for queueing:
+17 ; IBCNERTN="IBCNERPB" (current routine)
+18 ; IBCNESPC("PAPP")=Payer APPLICATION selected (1-eIV, 2-IIU, 3-Both)
+19 ; IBCNESPC("PDEACT")=Included Deactivated Payers? (1-include, 2-exclude)
+20 ; IBCNESPC("PDET")=Include Ins detail? (1-include list of ins, 2-do not list)
+21 ; IBCNESPC("POUT")=Output Format ('E'=EXCEL, 'R'=REPORT)
+22 ; IBCNESPC("PPYR")=Single Payer name or "" for ALL
+23 ; IBCNESPC("PSORT")=Primary Sort
+24 ; IBCNESPC("PTYPE")=Payer type (1-no active ins linked, 2-at least 1 ins linked, 3-All Payers)
+25 QUIT
+26 ;
COMPILE(IBCNERTN,IBCNESPC) ; Entry point called from EN^XUTMDEVQ.
+1 ; IBCNERTN = Routine name for ^TMP($J,...
+2 ; IBCNESPC = Array of params
+3 NEW PAPP,PDEACT,PDET,POUT,PPYR,PSORT,PTYPE
+4 ; IB*2*687/DTG start print msg in rept if no data for APP
+5 NEW IBII,IBIJ,IBAPP
+6 ; IB*2*687/DTG end print msg in rept if no data for APP
+7 ; Payer Application (1=eIV, 2=IIU, 3=Both)
SET PAPP=$GET(IBCNESPC("PAPP"))
+8 ; Deactivated Payers? (1=include, 0=exclude)
SET PDEACT=$GET(IBCNESPC("PDEACT"))
+9 ; Ins detail? (1=include list of ins, 2=do not list)
SET PDET=$GET(IBCNESPC("PDET"))
+10 ; Output Format ('E'=EXCEL, 'R'=Report)
SET POUT=$GET(IBCNESPC("POUT"))
+11 ; Single Payer name or "" for ALL
SET PPYR=$GET(IBCNESPC("PPYR"))
+12 ; Primary Sort
SET PSORT=$GET(IBCNESPC("PSORT"))
+13 ; Payer Type (1=no active ins linked, 2=at least 1 ins linked, 3=All Payers)
SET PTYPE=$GET(IBCNESPC("PTYPE"))
+14 KILL ^TMP($JOB,IBCNERTN)
+15 DO GETDATA
+16 DO PRINT
+17 ;
COMPILEX ; COMPILE exit
+1 KILL ^TMP($JOB,IBCNERTN)
+2 DO ^%ZISC
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
+5 ;
GETDATA ; Compile the data.
+1 ;IB*737/TAZ - Removed reference to Most Popular Payer and "~NO PAYER"
+2 NEW IBPY,IBPYR
+3 KILL ^TMP($JOB,IBCNERTN)
+4 ; IB*2*687/DTG start print msg in rept if no data for APP
+5 ; Create stub for EIV and IIU in TMP file for validation
+6 IF PAPP=""!(PAPP=1)!(PAPP=3)
SET ^TMP($JOB,IBCNERTN,"PAYER","EIV")=""
+7 IF PAPP=2!(PAPP=3)
SET ^TMP($JOB,IBCNERTN,"PAYER","IIU")=""
+8 ; IB*2*687/DTG end print msg in rept if no data for APP
+9 IF '$DATA(ZTQUEUED)
IF $GET(IOST)["C-"
IF POUT="R"
WRITE !!,"Compiling report data ..."
+10 ;
+11 ; SINGLE PAYER
+12 IF PPYR'=""
Begin DoDot:1
+13 ; Internal Payer ID number
SET IBPY=+PPYR
+14 ; Payer's Name
SET IBPYR=$PIECE(PPYR,U,2)
+15 ; Get the current payer's data
DO GETDATA1
+16 QUIT
End DoDot:1
QUIT
+17 ;
+18 ; ALL PAYERS (Loop thru #365.12)
+19 SET IBPY=0
+20 FOR
SET IBPY=$ORDER(^IBE(365.12,IBPY))
if 'IBPY
QUIT
Begin DoDot:1
+21 ; Don't want DEACTIVATED Payers
IF '+PDEACT
IF +$$PYRDEACT^IBCNINSU(+IBPY)
QUIT
+22 ; Payer name from (#365.12)
SET IBPYR=$$GET1^DIQ(365.12,IBPY,.01)
+23 ; Only accept eIV & IIU Payers
IF ($$PYRAPP^IBCNEUT5("EIV",IBPY)="")&($$PYRAPP^IBCNEUT5("IIU",IBPY)="")
QUIT
+24 DO GETDATA1
End DoDot:1
if $GET(ZTSTOP)
QUIT
+25 QUIT
+26 ;
GETDATA1 ; Process the current payer.
+1 NEW ALSOEIV,ALSOIIU,APPEIV,APPIIU,AUTUPD,EDIINST,EDIPROF,IBCT,IBEIVIEN,IBIIUIEN,IBINS,IBINSN,INSDATA
+2 NEW LOCENB,NATENB,NOLNKCOS,PAPPARY,PEINEIV,PEINIIU,RCVIIU,STATECD,VAID
+3 SET APPEIV=$$FIND1^DIC(365.13,,,"EIV")
SET APPIIU=$$FIND1^DIC(365.13,,,"IIU")
+4 ; Obtain all the Payer and Payer Application data
DO PAYER^IBCNINSU(IBPY,"","**","E",.PAPPARY)
+5 SET (PEINEIV,PEINIIU)=""
+6 SET IBEIVIEN=$$PYRAPP^IBCNEUT5("EIV",IBPY)
SET IBIIUIEN=$$PYRAPP^IBCNEUT5("IIU",IBPY)
+7 ; EIV App
IF IBEIVIEN
SET PEINEIV="EIV"_U_IBEIVIEN_","_IBPY_","
+8 ; IIU App
IF IBIIUIEN
SET PEINIIU="IIU"_U_IBIIUIEN_","_IBPY_","
+9 ;
+10 ; Only want eIV Payers and this Payer doesn't have an eIV app.
IF PAPP=1
IF PEINEIV=""
QUIT
+11 ; Only want IIU Payers and this Payer doesn't have an IIU app.
IF PAPP=2
IF PEINIIU=""
QUIT
+12 ;
+13 ; VA Nat'l Payer ID
SET VAID=$GET(PAPPARY(365.12,IBPY_",",.02,"E"))
+14 ; Inst & Prof EDI #s
SET EDIINST=$GET(PAPPARY(365.12,IBPY_",",.06,"E"))
SET EDIPROF=$GET(PAPPARY(365.12,IBPY_",",.05,"E"))
+15 ; eIV Also
SET ALSOEIV="NO"
IF PEINEIV'=""
SET ALSOEIV=$SELECT($GET(PAPPARY(365.121,$PIECE(PEINEIV,U,2),.01,"E"))="EIV":"YES",1:"NO")
+16 ; IIU Also
SET ALSOIIU="NO"
IF PEINIIU'=""
SET ALSOIIU=$SELECT($GET(PAPPARY(365.121,$PIECE(PEINIIU,U,2),.01,"E"))="IIU":"YES",1:"NO")
+17 ; Auto Update field for eIV
SET AUTUPD=""
IF PEINEIV'=""
SET AUTUPD=$GET(PAPPARY(365.121,$PIECE(PEINEIV,U,2),4.01,"E"))
+18 ; Receive IIU Data field for IIU
SET RCVIIU=""
IF PEINIIU'=""
SET RCVIIU=$GET(PAPPARY(365.121,$PIECE(PEINIIU,U,2),5.01,"E"))
+19 ; Nat'l Enabled Status for eIV
SET NATENB("EIV")="NO"
IF PEINEIV'=""
SET NATENB("EIV")=$SELECT($GET(PAPPARY(365.121,$PIECE(PEINEIV,U,2),.02,"E"))="Enabled":"YES",1:"NO")
+20 ; Nat'l Enabled Status for IIU
SET NATENB("IIU")="NO"
IF PEINIIU'=""
SET NATENB("IIU")=$SELECT($GET(PAPPARY(365.121,$PIECE(PEINIIU,U,2),.02,"E"))="Enabled":"YES",1:"NO")
+21 ; Locally Enabled Status for eIV
SET LOCENB("EIV")="NO"
IF PEINEIV'=""
SET LOCENB("EIV")=$SELECT($GET(PAPPARY(365.121,$PIECE(PEINEIV,U,2),.03,"E"))="Enabled":"YES",1:"NO")
+22 ; Locally Enabled Status for IIU
SET LOCENB("IIU")="NO"
IF PEINIIU'=""
SET LOCENB("IIU")=$SELECT($GET(PAPPARY(365.121,$PIECE(PEINIIU,U,2),.03,"E"))="Enabled":"YES",1:"NO")
+23 ;
+24 ; Get # of linked ins carriers for payer
+25 SET IBCT=0
SET IBINS=""
+26 ; Unlinked report-Only want payers without linked ins cos.
IF PTYPE=1
IF $DATA(^DIC(36,"AC",IBPY))
QUIT
+27 ; Linked report-Only want payers with linked ins cos.
IF PTYPE=2
IF '$DATA(^DIC(36,"AC",IBPY))
QUIT
+28 FOR
SET IBINS=$ORDER(^DIC(36,"AC",IBPY,IBINS))
if IBINS=""
QUIT
Begin DoDot:1
+29 SET IBINSN=$GET(^DIC(36,IBINS,0))
SET IBINSN=$PIECE(IBINSN,U)
if IBINSN=""
QUIT
+30 SET IBCT=IBCT+1
+31 ;If ins detail requested, save address & EDI#'s
+32 IF PDET=1
Begin DoDot:2
+33 SET STATECD=$$GET1^DIQ(36,IBINS,.115,"I")
+34 SET INSDATA=$$GET1^DIQ(36,IBINS,.111)_U_$$GET1^DIQ(36,IBINS,.114)_U_$PIECE($GET(^DIC(5,+STATECD,0)),U,2)_U_$$GET1^DIQ(36,IBINS,.116,"E")
+35 SET INSDATA=INSDATA_U_$$GET1^DIQ(36,IBINS,3.02)_U_$$GET1^DIQ(36,IBINS,3.04)
+36 SET ^TMP($JOB,IBCNERTN,"INSDTL",IBPY,IBINSN,IBINS)=INSDATA
End DoDot:2
End DoDot:1
+37 ;
SORTIT ; Set SORT params...use the negative of IBCT to sort in reverse order.
+1 ; SORT by Payer Name
IF PSORT=1
Begin DoDot:1
+2 SET SORT1=IBPYR
SET SORT2=VAID
SET SORT5=-IBCT
+3 ; For eIV or Both report
IF PEINEIV'=""
IF "^1^3^"[(U_PAPP_U)
Begin DoDot:2
+4 SET SORT3=NATENB("EIV")
SET SORT4=LOCENB("EIV")
+5 DO SAVDATA("EIV")
End DoDot:2
+6 ; For IIU or Both report
IF PEINIIU'=""
IF "^2^3^"[(U_PAPP_U)
Begin DoDot:2
+7 SET SORT3=NATENB("IIU")
SET SORT4=LOCENB("IIU")
+8 DO SAVDATA("IIU")
End DoDot:2
End DoDot:1
+9 ;
+10 ; SORT by VAID
IF PSORT=2
Begin DoDot:1
+11 SET SORT1=VAID
SET SORT2=IBPYR
SET SORT5=-IBCT
+12 ; For eIV or Both report
IF PEINEIV'=""
IF "^1^3^"[(U_PAPP_U)
Begin DoDot:2
+13 SET SORT3=NATENB("EIV")
SET SORT4=LOCENB("EIV")
+14 DO SAVDATA("EIV")
End DoDot:2
+15 ; For IIU or Both report
IF PEINIIU'=""
IF "^2^3^"[(U_PAPP_U)
Begin DoDot:2
+16 SET SORT3=NATENB("IIU")
SET SORT4=LOCENB("IIU")
+17 DO SAVDATA("IIU")
End DoDot:2
End DoDot:1
+18 ;
+19 ; SORT by Nat'l Enabled Status
IF PSORT=3
Begin DoDot:1
+20 SET SORT2=IBPYR
SET SORT3=VAID
SET SORT5=-IBCT
+21 ; For eIV or Both report
IF PEINEIV'=""
IF "^1^3^"[(U_PAPP_U)
Begin DoDot:2
+22 SET SORT1=NATENB("EIV")
SET SORT4=LOCENB("EIV")
+23 DO SAVDATA("EIV")
End DoDot:2
+24 ; For IIU or Both report
IF PEINIIU'=""
IF "^2^3^"[(U_PAPP_U)
Begin DoDot:2
+25 SET SORT1=NATENB("IIU")
SET SORT4=LOCENB("IIU")
+26 DO SAVDATA("IIU")
End DoDot:2
End DoDot:1
+27 ;
+28 ; SORT by Locally Enabled Status
IF PSORT=4
Begin DoDot:1
+29 SET SORT2=IBPYR
SET SORT3=VAID
SET SORT5=-IBCT
+30 ; For eIV or Both report
IF PEINEIV'=""
IF "^1^3^"[(U_PAPP_U)
Begin DoDot:2
+31 SET SORT1=LOCENB("EIV")
SET SORT4=NATENB("EIV")
+32 DO SAVDATA("EIV")
End DoDot:2
+33 ; For IIU or Both report
IF PEINIIU'=""
IF "^2^3^"[(U_PAPP_U)
Begin DoDot:2
+34 SET SORT1=LOCENB("IIU")
SET SORT4=NATENB("IIU")
+35 DO SAVDATA("IIU")
End DoDot:2
End DoDot:1
+36 ;
+37 ; SORT by # of ins cos
IF PSORT=5
Begin DoDot:1
+38 SET SORT1=-IBCT
SET SORT2=IBPYR
SET SORT3=VAID
+39 ; For eIV or Both report
IF PEINEIV'=""
IF "^1^3^"[(U_PAPP_U)
Begin DoDot:2
+40 SET SORT4=NATENB("EIV")
SET SORT5=LOCENB("EIV")
+41 DO SAVDATA("EIV")
End DoDot:2
+42 ; For IIU or Both report
IF PEINIIU'=""
IF "^2^3^"[(U_PAPP_U)
Begin DoDot:2
+43 SET SORT4=NATENB("IIU")
SET SORT5=LOCENB("IIU")
+44 DO SAVDATA("IIU")
End DoDot:2
End DoDot:1
+45 QUIT
+46 ;
SAVDATA(APP) ; Save data to print
+1 ; REPORT format
IF POUT="R"
Begin DoDot:1
+2 SET ^TMP($JOB,IBCNERTN,"PAYER",APP,SORT1,SORT2,SORT3,SORT4,SORT5)=IBPY_U_IBPYR_U_VAID_U_EDIPROF_U_EDIINST_U_$GET(NATENB(APP))_U_$GET(LOCENB(APP))_U_$SELECT(APP="IIU":RCVIIU,1:$GET(AUTUPD))_U_$SELECT(APP="IIU":ALSOEIV,1:ALSOIIU)_U_IBCT
End DoDot:1
QUIT
+3 ; EXCEL format - only want to report a payer once in EXCEL format.
+4 IF '$DATA(^TMP($JOB,IBCNERTN,"PAYER",SORT1))
SET ^TMP($JOB,IBCNERTN,"PAYER",SORT1,SORT2,SORT3,SORT4,SORT5)=IBPY_U_IBPYR_U_VAID_U_EDIPROF_U_EDIINST_U_IBCT_U_$GET(NATENB("EIV"))_U_LOCENB("EIV")_U_$GET(AUTUPD)_U_NATENB("IIU")_U_LOCENB("IIU")_U_$GET(RCVIIU)
+5 QUIT
+6 ;
PRINT ;
+1 NEW APP,CRT,DASHES,EORMSG,HDRDATE,HDRNAME,IBPGC,IBPXT,MAXCNT,NONEMSG,PREVAPP,SORT1,SORT2,SORT3,SORT4,SORT5,ZTSTOP,DIS
+2 SET EORMSG="*** END OF REPORT ***"
+3 SET NONEMSG="* * * N O D A T A F O U N D * * *"
+4 SET HDRNAME="Payer Link Report"
SET HDRDATE=$$FMTE^XLFDT($$NOW^XLFDT,1)_" Page: "
+5 SET $PIECE(DASHES,"-",131)=""
SET (APP,SORT1,SORT2,SORT3,SORT4,SORT5)=""
+6 SET (IBPXT,IBPGC)=0
+7 ; IO params
+8 IF "^R^E^"'[(U_$GET(POUT)_U)
SET POUT="R"
+9 SET MAXCNT=IOSL-3
SET CRT=1
+10 IF IOST'["C-"
SET MAXCNT=IOSL-6
SET CRT=0
+11 ; Print report
DO PRINT1
if (IBPXT!$GET(ZTSTOP))
QUIT
+12 IF CRT
IF IBPGC>0
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+13 IF MAXCNT<51
FOR LIN=1:1:(MAXCNT-$Y)
WRITE !
+14 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
+15 ; End of the EXCEL Report
IF POUT="E"
IF CRT
IF '$DATA(ZTQUEUED)
SET DIR(0)="E"
DO ^DIR
KILL DIR
+16 QUIT
+17 ;
PRINT1 ; Print report
+1 SET (APP,PREVAPP)=""
+2 ; EXCEL Format
+3 IF POUT="E"
Begin DoDot:1
+4 ; EXCEL Header
DO EHDR
+5 IF '$DATA(^TMP($JOB,IBCNERTN))
Begin DoDot:2
+6 DO HEADER(APP,HDRNAME,HDRDATE)
+7 ; Nothing to print.
WRITE !,?$$CENTER(NONEMSG,132),NONEMSG,!!
QUIT
End DoDot:2
QUIT
+8 ;
+9 ; Process through the Sort array
+10 SET SORT1=""
FOR
SET SORT1=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",SORT1))
if SORT1=""
QUIT
Begin DoDot:2
+11 SET SORT2=""
FOR
SET SORT2=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",SORT1,SORT2))
if SORT2=""
QUIT
Begin DoDot:3
+12 SET SORT3=""
FOR
SET SORT3=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",SORT1,SORT2,SORT3))
if SORT3=""
QUIT
Begin DoDot:4
+13 SET SORT4=""
FOR
SET SORT4=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",SORT1,SORT2,SORT3,SORT4))
if SORT4=""
QUIT
Begin DoDot:5
+14 SET SORT5=""
FOR
SET SORT5=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",SORT1,SORT2,SORT3,SORT4,SORT5))
if SORT5=""
QUIT
Begin DoDot:6
+15 ; Init disp
KILL DISPDATA
+16 ; build/display data
DO DATA(.DISPDATA)
DO LINE(.DISPDATA)
End DoDot:6
if (IBPXT!$GET(ZTSTOP))
QUIT
End DoDot:5
if (IBPXT!$GET(ZTSTOP))
QUIT
End DoDot:4
if (IBPXT!$GET(ZTSTOP))
QUIT
End DoDot:3
if (IBPXT!$GET(ZTSTOP))
QUIT
End DoDot:2
if (IBPXT!$GET(ZTSTOP))
QUIT
End DoDot:1
GOTO PRINT2
+17 ;
+18 ; REPORT Format
+19 IF '$DATA(^TMP($JOB,IBCNERTN))
Begin DoDot:1
+20 ; IB*2*687/DTG start print msg in rept if no data FOUND, make sure all APP's for report are covered
+21 SET IBII=$SELECT(PAPP=1:1,PAPP=2:2,PAPP=3:2,1:1)
+22 ;<
FOR IBIJ=1:1:IBII
SET IBAPP=$PIECE("EIV,IIU",",",IBIJ)
IF PAPP=3!(IBIJ=1&(PAPP=1))!(IBIJ=2&(PAPP=2))
Begin DoDot:2
+23 DO HEADER(IBAPP,HDRNAME,HDRDATE)
+24 ; Nothing to print.
WRITE !,?$$CENTER(NONEMSG,132),NONEMSG,!!
QUIT
End DoDot:2
+25 ; IB*2*687/DTG end print msg in rept if no data for APP
End DoDot:1
QUIT
+26 ;
+27 ; Process through the Sort array
+28 FOR
SET APP=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",APP))
if APP=""
QUIT
Begin DoDot:1
+29 SET PREVAPP=APP
+30 ; IB*2*687/DTG start print msg in rept if no data for APP
+31 ; added a DO layer in order to check if data for APP
+32 ;<
IF POUT="R"
Begin DoDot:2
+33 IF $DATA(^TMP($JOB,IBCNERTN,"PAYER",APP))<10
Begin DoDot:3
+34 DO HEADER(APP,HDRNAME,HDRDATE)
+35 WRITE !,?$$CENTER(NONEMSG,132),NONEMSG,!!
End DoDot:3
QUIT
+36 ; print no data found if APP does not have data
+37 ; REPORT Header
DO HEADER(APP,HDRNAME,HDRDATE)
if (IBPXT!$GET(ZTSTOP))
QUIT
+38 SET SORT1=""
FOR
SET SORT1=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",APP,SORT1))
if SORT1=""
QUIT
Begin DoDot:3
+39 SET SORT2=""
FOR
SET SORT2=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",APP,SORT1,SORT2))
if SORT2=""
QUIT
Begin DoDot:4
+40 SET SORT3=""
FOR
SET SORT3=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",APP,SORT1,SORT2,SORT3))
if SORT3=""
QUIT
Begin DoDot:5
+41 SET SORT4=""
FOR
SET SORT4=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",APP,SORT1,SORT2,SORT3,SORT4))
if SORT4=""
QUIT
Begin DoDot:6
+42 SET SORT5=""
FOR
SET SORT5=$ORDER(^TMP($JOB,IBCNERTN,"PAYER",APP,SORT1,SORT2,SORT3,SORT4,SORT5))
if SORT5=""
QUIT
Begin DoDot:7
+43 ; Init disp
KILL DISPDATA
+44 ; build/display data
DO DATA(.DISPDATA)
DO LINE(.DISPDATA)
End DoDot:7
if (IBPXT!$GET(ZTSTOP))
QUIT
End DoDot:6
if (IBPXT!$GET(ZTSTOP))
QUIT
End DoDot:5
if (IBPXT!$GET(ZTSTOP))
QUIT
End DoDot:4
if (IBPXT!$GET(ZTSTOP))
QUIT
End DoDot:3
if (IBPXT!$GET(ZTSTOP))
QUIT
End DoDot:2
+45 ; IB*2*687/DTG end print msg in rept if no data for APP
End DoDot:1
if (IBPXT!$GET(ZTSTOP))
QUIT
+46 ;
PRINT2 ;
+1 IF IBPXT!$GET(ZTSTOP)
QUIT
+2 ;
+3 IF POUT="R"
Begin DoDot:1
+4 IF $Y+1>MAXCNT!('IBPGC)
DO HEADER(PREVAPP,HDRNAME,HDRDATE)
End DoDot:1
if (IBPXT!$GET(ZTSTOP))
QUIT
+5 WRITE !,?$$CENTER(EORMSG,132),EORMSG
+6 QUIT
+7 ;
+1 NEW DIR,DTOUT,DUOUT,HDR,HDRDET,LIN,OFFSET1,OFFSET2,X,Y
+2 IF CRT
IF IBPGC>0
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+3 IF MAXCNT<51
FOR LIN=1:1:(MAXCNT-$Y)
WRITE !
+4 SET DIR(0)="E"
DO ^DIR
KILL DIR
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBPXT=1
QUIT
End DoDot:1
if IBPXT
QUIT
+6 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+7 SET IBPGC=IBPGC+1
SET HDRDATE=HDRDATE_+IBPGC
SET HDRDET=""
+8 IF PPYR=""
SET HDRDET="All "_$SELECT(PTYPE=1:"Unlinked ",PTYPE=2:"Linked ",1:"")_APP_" Payers"
+9 IF PTYPE'=1
Begin DoDot:1
+10 IF $LENGTH(HDRDET)
SET HDRDET=HDRDET_", "
+11 ; IB*2*687/DTG start change for space
+12 SET HDRDET=HDRDET_$SELECT(PDET=1:"With",1:"Without")_" Ins. Co. Detail"
+13 ; IB*2*687/DTG end change for space
End DoDot:1
+14 SET OFFSET1=$$CENTER(HDRDET,(132-$LENGTH(HDRNAME)))
+15 SET OFFSET2=131-$LENGTH(HDRDATE)
+16 WRITE @IOF,!,HDRNAME,?OFFSET1,HDRDET,?OFFSET2,HDRDATE
+17 WRITE !
+18 IF PPYR'=""
WRITE ?1,APP," Payer: ",$PIECE(PPYR,"^",2)
+19 ;W !,?46,"# Linked",?63,"Nationally",?82,"Locally"
+20 ;IB*752/DTG to tell which is IIU and EIV
WRITE !,?46,"# Linked",?63,$SELECT(APP="IIU":"IIU",1:"EIV")," Nationally",?82,$SELECT(APP="IIU":"IIU",1:"EIV")," Locally"
+21 WRITE ?98,$SELECT(APP="IIU":"Receive",1:"Auto")
+22 WRITE ?113,"Prof/Inst.",?126,"Also"
+23 ; IB*2*687/DTG start remove ':' from payer name
+24 WRITE !,"Payer Name"
+25 WRITE ?32,"VA ID",?46,"Ins. Co.",?63,"Enabled",?82,"Enabled"
+26 ; IB*2*687/DTG end remove ':' from payer name
+27 WRITE ?98,$SELECT(APP="IIU":"IIU Data",1:"Update")
+28 WRITE ?113,"EDI#",?126,$SELECT(APP="EIV":"IIU",1:"EIV")
+29 WRITE !,DASHES
+30 QUIT
+31 ;
+32 ; IB*2*687/DTG start change for space DISPDATA - DIS,RPTDATA - RPT,INCODATA - INCO,INSNAME - INSNA,INSREC - INSR
DATA(DIS) ; Build disp lines
+1 NEW CITY,CSZ,CT,CT2,ELINE,INCO,INSNA,INSNO,INSR,LCT,PYRNO,RPT,SPACES,STZIP
+2 ; Merge into local array
+3 SET $PIECE(SPACES," ",100)=" "
+4 IF POUT="E"
MERGE RPT=^TMP($JOB,IBCNERTN,"PAYER",SORT1,SORT2,SORT3,SORT4,SORT5)
+5 IF POUT="R"
MERGE RPT=^TMP($JOB,IBCNERTN,"PAYER",APP,SORT1,SORT2,SORT3,SORT4,SORT5)
+6 ; Ins Co Detail
MERGE INCO=^TMP($JOB,IBCNERTN,"INSDTL",$PIECE(RPT,U,1))
+7 ;
+8 ; EXCEL format
+9 IF POUT="E"
Begin DoDot:1
+10 NEW IBINSN,IBINS,IBPY,INSR,LCT,XX
+11 SET IBPY=$PIECE(RPT,U)
SET ELINE=$PIECE(RPT,U,2,12)
+12 IF (PDET=2!'$DATA(^TMP($JOB,IBCNERTN,"INSDTL",IBPY)))
SET LCT=1
SET DIS(LCT)=ELINE
QUIT
+13 ;Print Ins Co Detail
+14 SET (IBINSN,IBINS,XX)=""
SET LCT=0
+15 IF $DATA(^TMP($JOB,IBCNERTN,"INSDTL",IBPY))
Begin DoDot:2
+16 FOR
SET IBINSN=$ORDER(^TMP($JOB,IBCNERTN,"INSDTL",IBPY,IBINSN))
if IBINSN=""
QUIT
Begin DoDot:3
+17 FOR
SET IBINS=$ORDER(^TMP($JOB,IBCNERTN,"INSDTL",IBPY,IBINSN,IBINS))
if IBINS=""
QUIT
Begin DoDot:4
+18 SET INSR=^TMP($JOB,IBCNERTN,"INSDTL",IBPY,IBINSN,IBINS)
+19 SET LCT=LCT+1
+20 SET DIS(LCT)=ELINE_U_IBINSN_U_INSR
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
QUIT
+21 ;
+22 ; Format 1st line (payer)
+23 SET LCT=1
SET DIS(LCT)=$$FO^IBCNEUT1($EXTRACT($PIECE(RPT,U,2),1,30),32,"L")_$$FO^IBCNEUT1($PIECE(RPT,U,3),14,"L")_$$FO^IBCNEUT1($PIECE(RPT,U,10),17,"L")
+24 SET DIS(LCT)=DIS(LCT)_$$FO^IBCNEUT1($PIECE(RPT,U,6),19,"L")_$$FO^IBCNEUT1($PIECE(RPT,U,7),16,"L")_$$FO^IBCNEUT1($PIECE(RPT,U,8),15,"L")
+25 IF $PIECE(RPT,U,4)'=""!($PIECE(RPT,U,5)'="")
SET DIS(LCT)=DIS(LCT)_$$FO^IBCNEUT1($PIECE(RPT,U,4),5,"R")_"/"_$$FO^IBCNEUT1($PIECE(RPT,U,5),7,"L")
+26 ; If nothing to print, substitute spaces.
IF $PIECE(RPT,U,4)=""
IF $PIECE(RPT,U,5)=""
SET DIS(LCT)=DIS(LCT)_$EXTRACT(SPACES,1,13)
+27 SET DIS(LCT)=DIS(LCT)_$$FO^IBCNEUT1($PIECE(RPT,U,9),3,"L")
+28 ;
+29 ; Format Ins Co detail
IF PDET=1
Begin DoDot:1
+30 IF $ORDER(INCO(""))'=""
Begin DoDot:2
+31 SET LCT=LCT+1
+32 SET DIS(LCT)=" Linked Insurance Companies Address"_$EXTRACT(SPACES,1,30)_"City, State, Zip code"
+33 SET (INSNA,INSNO,INSDATA)=""
+34 FOR
SET INSNA=$ORDER(INCO(INSNA))
if INSNA=""
QUIT
Begin DoDot:3
+35 FOR
SET INSNO=$ORDER(INCO(INSNA,INSNO))
if INSNO=""
QUIT
Begin DoDot:4
+36 SET INSDATA=INCO(INSNA,INSNO)
+37 SET LCT=LCT+1
SET DIS(LCT)=" "_$$FO^IBCNEUT1(INSNA,33,"L")_$$FO^IBCNEUT1($PIECE(INSDATA,U,1),37,"L")
+38 SET CITY=$PIECE(INSDATA,U,2)
+39 ; don't display ',' if no address/state on file
+40 SET STZIP=""
+41 IF $PIECE(INSDATA,U,3)'=""
SET STZIP=", "_$PIECE(INSDATA,U,3)
+42 IF $PIECE(INSDATA,U,4)'=""
SET STZIP=STZIP_" "_$PIECE(INSDATA,U,4)
+43 SET CSZ=$EXTRACT(CITY,1,39-$LENGTH(STZIP))_STZIP
+44 SET DIS(LCT)=DIS(LCT)_$$FO^IBCNEUT1(CSZ,41,"L")
+45 IF $PIECE(INSDATA,U,5)'=""!($PIECE(INSDATA,U,6)'="")
SET DIS(LCT)=DIS(LCT)_$$FO^IBCNEUT1($PIECE(INSDATA,U,5),5,"R")_"/"_$$FO^IBCNEUT1($PIECE(INSDATA,U,6),7,"L")
+46 ; If nothing to print, substitute spaces.
IF $PIECE(RPT,U,5)=""
IF $PIECE(RPT,U,6)=""
SET DIS(LCT)=DIS(LCT)_$EXTRACT(SPACES,1,13)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+47 ; IB*2*687/DTG end change for space DISPDATA - DIS,RPTDATA - RPT,INCODATA - INCO,INSNAME - INSNA,INSREC - INSR
+48 SET LCT=LCT+1
+49 QUIT
+50 ;
EHDR ; EXCEL header
+1 NEW HDR,X
+2 SET HDR=""
SET X="Payer Link Report^"
+3 WRITE X
+4 ; IB*2*687/DTG start change for space
+5 IF PPYR=""
SET HDR=$SELECT(PTYPE=1:"Unlinked",PTYPE=2:"Linked",1:"All")_" Payers"_"^"
+6 ; If not "unlinked" check for detail option.
+7 IF PTYPE'=1
SET HDR=HDR_$SELECT(PDET=1:"With",1:"Without")_" Ins. Co. Detail"_"^"
WRITE HDR
+8 ; IB*2*687/DTG end change for space
+9 WRITE $$FMTE^XLFDT($$NOW^XLFDT,1)
+10 ;
+11 IF PPYR'=""
WRITE !,"For Single Payer:"_"^"_$PIECE(PPYR,"^",2)
+12 ;
+13 SET X="Payer Name^VA ID^Elig Prof EDI#^Elig Inst EDI#^# Linked Ins. Co.^eIV Natl Enabled^eIV Locally Enabled^eIV Auto Update^IIU Natl Enabled^IIU Locally Enabled^Receive IIU Data"
+14 IF PDET=1
SET X=X_"^Company Name^St Address^City^ST^Zip^Claims Prof EDI#^Claims Inst EDI#"
+15 WRITE !,X
+16 QUIT
+17 QUIT
+18 ;
+19 ; IB*2*687/DTG start change for space
LINE(DIS) ; Print data
+1 NEW LNCT,LNTOT,NWPG
+2 SET LNTOT=+$ORDER(DIS(""),-1)
+3 SET NWPG=0
+4 FOR LNCT=1:1:LNTOT
Begin DoDot:1
+5 IF POUT="R"
Begin DoDot:2
+6 IF $Y+1>MAXCNT!('IBPGC)
DO HEADER(APP,HDRNAME,HDRDATE)
SET NWPG=1
IF $GET(ZTSTOP)!IBPXT
QUIT
End DoDot:2
if (IBPXT!$GET(ZTSTOP))
QUIT
+7 WRITE !,DIS(LNCT)
End DoDot:1
if (IBPXT!$GET(ZTSTOP))
QUIT
+8 ; IB*2*687/DTG end change for space
+9 QUIT
LINEX QUIT
+1 ;
CENTER(LINE,XWIDTH) ;return centered line OFFSET
+1 ; IB*2*687/DTG start change for space
+2 NEW LE,OF
+3 SET LE=$LENGTH(LINE)
SET OF=XWIDTH-$LENGTH(LINE)\2
+4 QUIT OF
+5 ; IB*2*687/DTG end change for space
+6 ;
