IBINRPT ;YMG/EDE - AI/AN (MEGABUS Act) Copay Exemption Report ;NOV 23 2021
;;2.0;INTEGRATED BILLING;**716,782**;21-MAR-94;Build 9
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to FILE #2 in ICR #7300
;
Q
;
EN ; entry point
N EXCEL,IBEND,IBSTART,QUIT
N POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
K ^TMP("IBINRPT",$J)
W !!,"AI/AN Verified Copay Exemption Report",!
; ask for dates
S QUIT=0 D ASKDT I QUIT Q
; export to Excel?
S EXCEL=$$GETEXCEL^IBUCMM() I EXCEL<0 Q
I EXCEL D PRTEXCEL^IBUCMM()
I 'EXCEL W !!,"This report requires 132 column display.",!
; ask for device
K IOP,IO("Q")
S %ZIS="MQ",%ZIS("B")="",POP=0 D ^%ZIS Q:POP
I $D(IO("Q")) D Q ; queued report
.S ZTDESC="AI/AN Verified Copay Exemption Report",ZTRTN="COMPILE^IBINRPT"
.S ZTSAVE("EXCEL")="",ZTSAVE("IBEND")="",ZTSAVE("IBSTART")="",ZTSAVE("ZTREQ")="@" ; IB*2.0*782
.D ^%ZTLOAD,HOME^%ZIS
.I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",! D PAUSE
.Q
D COMPILE
Q
;
COMPILE ; compile report
N IBBLNO,IBCHRG,IBCHTYPE,IBDATA,IBDFN,IBFR,IBGRP,IBIEN,IBIENS,IBINDTM,IBINFLG,IBINSTDT,IBNM,IBPID,IBSTATNM,IBTO,Z
S IBINDTM=IBSTART-.001 F S IBINDTM=$O(^DPT("AINC",IBINDTM)) Q:'IBINDTM!($P(IBINDTM,".")>IBEND) D
.S IBDFN=0 F S IBDFN=$O(^DPT("AINC",IBINDTM,IBDFN)) Q:'IBDFN D
..S Z=$$INDGET^IBINUT1(IBDFN)
..S IBINFLG=$P(Z,U) ; AI/AN self-identification flag (Y/N)
..S IBINSTDT=$P(Z,U,2) ; AI/AN self-identification start date
..S IBIEN=0 F S IBIEN=$O(^IB("C",IBDFN,IBIEN)) Q:'IBIEN D
...S IBDATA=^IB(IBIEN,0) ; file 350 node 0
...S IBTO=+$P(IBDATA,U,15) ; "Bill To" date
...I '$$INDCHKDT^IBINUT1(IBTO,IBINSTDT) Q ; bill timeframe is not covered by exemption
...S IBIENS=IBIEN_"," ; IB*2.0*782
...S IBSTATNM=$$GET1^DIQ(350,IBIENS,.05,"E") ; bill status (350/.05) - external
...; check bill status
...I IBINFLG'="Y" Q
...I IBINFLG="Y","^BILLED^HOLD - RATE^HOLD - REVIEW^ON HOLD^"'[(U_IBSTATNM_U) Q
...S IBCHTYPE=$P(IBDATA,U,3) Q:IBCHTYPE="" ; charge type (350/.03)
...S IBGRP=$P(^IBE(350.1,IBCHTYPE,0),U,11) I IBGRP=7!(IBGRP=9) Q ; quit if LTC or Tricare charge
...Q:$$GET1^DIQ(350.1,IBCHTYPE,.05,"E")'="NEW"
...S IBBLNO=$P(IBDATA,U,11) ; bill #
...S Z=$$PATID(IBDFN),IBPID=$P(Z,U),IBNM=$P(Z,U,2) ; patient id and name
...S IBCHRG=$P(IBDATA,U,7) ; bill amount (350/.07)
...S IBFR=$P(IBDATA,U,14) ; "Bill From" date
...S ^TMP("IBINRPT",$J,IBDFN,IBIEN)=IBNM_U_IBPID_U_IBINSTDT_U_IBBLNO_U_IBCHTYPE_U_IBSTATNM_U_IBFR_U_IBTO_U_IBCHRG
...S ^TMP("IBINRPT",$J,"IDX",IBNM,IBDFN)=""
...Q
..Q
.Q
D PRINT
K ^TMP("IBINRPT",$J)
Q
;
PRINT ; print report
N EXTDT,IBCHRG,IBCHTYPE,IBDATA,IBDFN,IBNM,LN,PAGE,QUIT
U IO
S (PAGE,QUIT)=0
S EXTDT=$$FMTE^XLFDT(DT)
I EXCEL D
.W !,"AI/AN Verified Copay Exemption Report",U,EXTDT,U,$$FMTE^XLFDT(IBSTART),"-",$$FMTE^XLFDT(IBEND)
.W !,"Name^ID^AI/AN Start date^Bill #^Charge type^Bill status^Bill From date^Bill To Date^Bill amount"
.Q
I 'EXCEL D
.I $E(IOST,1,2)["C-",'$D(ZTQUEUED) W @IOF
.D HDR
.Q
I '$D(^TMP("IBINRPT",$J)) D Q
.I EXCEL W !!,"No records found." Q
.W !!,$$CJ^XLFSTR("No records found.",132)
.I PAGE>0,'$D(ZTQUEUED) W ! D PAUSE W @IOF
.Q
S IBNM="" F S IBNM=$O(^TMP("IBINRPT",$J,"IDX",IBNM)) Q:IBNM=""!QUIT D
.S IBDFN="" F S IBDFN=$O(^TMP("IBINRPT",$J,"IDX",IBNM,IBDFN)) Q:IBDFN=""!QUIT D
..S IBIEN="" F S IBIEN=$O(^TMP("IBINRPT",$J,IBDFN,IBIEN)) Q:IBIEN=""!QUIT D
...S IBDATA=^TMP("IBINRPT",$J,IBDFN,IBIEN)
...S IBCHTYPE=$$GET1^DIQ(350.1,$P(IBDATA,U,5),.01,"E")
...S IBCHRG=$FN($P(IBDATA,U,9),"",2)
...I EXCEL D Q
....W !,$P(IBDATA,U),U,$P(IBDATA,U,2),U,$$FMTE^XLFDT($P(IBDATA,U,3),"2Z"),U,$P(IBDATA,U,4),U,IBCHTYPE,U,$P(IBDATA,U,6),U
....W $$FMTE^XLFDT($P(IBDATA,U,7),"2DZ"),U,$$FMTE^XLFDT($P(IBDATA,U,8),"2DZ"),U,IBCHRG ; IB*2.0*782
....Q
...S LN=LN+1
...W !,$E($P(IBDATA,U),1,25),?27,$P(IBDATA,U,2),?34,$$FMTE^XLFDT($P(IBDATA,U,3),"2Z"),?45,$$CJ^XLFSTR($P(IBDATA,U,4),12),?58
...W $E(IBCHTYPE,1,12),?72,$$CJ^XLFSTR($P(IBDATA,U,6),13),?88,$$FMTE^XLFDT($P(IBDATA,U,7),"2DZ"),?99,$$FMTE^XLFDT($P(IBDATA,U,8),"2DZ"),?107 ; IB*2.0*782
...W $$CJ^XLFSTR("$"_IBCHRG,11) ; IB*2.0*782
...I LN>(IOSL-3) D HDR I QUIT Q
...Q
..Q
.Q
I PAGE>0,'$D(ZTQUEUED),'QUIT W !!,$$CJ^XLFSTR("End of report.",132) D PAUSE W @IOF
Q
;
HDR ; print header
I PAGE>0,'$D(ZTQUEUED) D PAUSE W @IOF I $G(QUIT) Q
S PAGE=PAGE+1,LN=7
W !,"AI/AN Verified Copay Exemption Report",?66,EXTDT,?119,"Page: ",PAGE
W !,"AI/AN Change dates: ",$$FMTE^XLFDT(IBSTART)," - ",$$FMTE^XLFDT(IBEND)
W !
W !," AI/AN Bill From Bill To Bill "
W !,"Name ID Start Date Bill # Charge Type Bill Status Date Date Amount"
W ! D DASH(132)
Q
;
DASH(LEN) ; print line of dashes
N DASH
S $P(DASH,"-",LEN+1)="" W DASH
Q
;
PATID(DFN) ; returns Id for a given patient
;
; DFN - patient's DFN
;
; returns [first letter of the last name]_[last 4 digits of the SSN for a given patient] ^ patient name, or "" if unable to get the Id
;
N IBNM,VADM
I +$G(DFN)'>0 Q ""
D DEM^VADPT
S IBNM=VADM(1)
Q $E(IBNM,1)_$P($P(VADM(2),U,2),"-",3)_U_IBNM
;
ASKDT ; prompt for start and end dates
;
; sets IBSTART and IBEND vars to start date and end date respectively, sets QUIT=1 on user exit
;
N DIR,DUOUT,DTOUT,DIRUT,X,Y
S DIR(0)="DA^3220105:"_DT_":EX" ; IB*2.0*782
S DIR("A")="Start with AI/AN change date: "
S DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-7),"1D")
S DIR("?",2)=" Please enter a valid start date." ; IB*2.0*782
S DIR("?",1)=" This date must not precede 01/05/22." ; IB*2.0*782
S DIR("?")=" This date must not be in the future." ; IB*2.0*782
D ^DIR
I $D(DIRUT) S QUIT=1 G ASKDTX
S IBSTART=Y
; End date
ASKDT1 ;
S DIR(0)="DA^"_IBSTART_":"_DT_":EX" ; IB*2.0*782
S DIR("A")=" End with AI/AN change date: "
S DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT),"1D")
S DIR("?",2)=" Please enter a valid end date." ; IB*2.0*782
S DIR("?",1)=" This date must not precede the start date entered above." ; IB*2.0*782
S DIR("?")=" This date must not be in the future." ; IB*2.0*782
D ^DIR
I $D(DIRUT) S QUIT=1 G ASKDTX
S IBEND=Y
;
ASKDTX ; dates prompt exit point
Q
;
PAUSE ; "Type <Enter> to continue" prompt
N DIR,DUOUT,DTOUT,DIRUT,X,Y
S DIR(0)="E" D ^DIR
I $D(DIRUT) S QUIT=1
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBINRPT 6530 printed Dec 13, 2024@02:22:31 Page 2
IBINRPT ;YMG/EDE - AI/AN (MEGABUS Act) Copay Exemption Report ;NOV 23 2021
+1 ;;2.0;INTEGRATED BILLING;**716,782**;21-MAR-94;Build 9
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to FILE #2 in ICR #7300
+5 ;
+6 QUIT
+7 ;
EN ; entry point
+1 NEW EXCEL,IBEND,IBSTART,QUIT
+2 NEW POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
+3 KILL ^TMP("IBINRPT",$JOB)
+4 WRITE !!,"AI/AN Verified Copay Exemption Report",!
+5 ; ask for dates
+6 SET QUIT=0
DO ASKDT
IF QUIT
QUIT
+7 ; export to Excel?
+8 SET EXCEL=$$GETEXCEL^IBUCMM()
IF EXCEL<0
QUIT
+9 IF EXCEL
DO PRTEXCEL^IBUCMM()
+10 IF 'EXCEL
WRITE !!,"This report requires 132 column display.",!
+11 ; ask for device
+12 KILL IOP,IO("Q")
+13 SET %ZIS="MQ"
SET %ZIS("B")=""
SET POP=0
DO ^%ZIS
if POP
QUIT
+14 ; queued report
IF $DATA(IO("Q"))
Begin DoDot:1
+15 SET ZTDESC="AI/AN Verified Copay Exemption Report"
SET ZTRTN="COMPILE^IBINRPT"
+16 ; IB*2.0*782
SET ZTSAVE("EXCEL")=""
SET ZTSAVE("IBEND")=""
SET ZTSAVE("IBSTART")=""
SET ZTSAVE("ZTREQ")="@"
+17 DO ^%ZTLOAD
DO HOME^%ZIS
+18 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
DO PAUSE
+19 QUIT
End DoDot:1
QUIT
+20 DO COMPILE
+21 QUIT
+22 ;
COMPILE ; compile report
+1 NEW IBBLNO,IBCHRG,IBCHTYPE,IBDATA,IBDFN,IBFR,IBGRP,IBIEN,IBIENS,IBINDTM,IBINFLG,IBINSTDT,IBNM,IBPID,IBSTATNM,IBTO,Z
+2 SET IBINDTM=IBSTART-.001
FOR
SET IBINDTM=$ORDER(^DPT("AINC",IBINDTM))
if 'IBINDTM!($PIECE(IBINDTM,".")>IBEND)
QUIT
Begin DoDot:1
+3 SET IBDFN=0
FOR
SET IBDFN=$ORDER(^DPT("AINC",IBINDTM,IBDFN))
if 'IBDFN
QUIT
Begin DoDot:2
+4 SET Z=$$INDGET^IBINUT1(IBDFN)
+5 ; AI/AN self-identification flag (Y/N)
SET IBINFLG=$PIECE(Z,U)
+6 ; AI/AN self-identification start date
SET IBINSTDT=$PIECE(Z,U,2)
+7 SET IBIEN=0
FOR
SET IBIEN=$ORDER(^IB("C",IBDFN,IBIEN))
if 'IBIEN
QUIT
Begin DoDot:3
+8 ; file 350 node 0
SET IBDATA=^IB(IBIEN,0)
+9 ; "Bill To" date
SET IBTO=+$PIECE(IBDATA,U,15)
+10 ; bill timeframe is not covered by exemption
IF '$$INDCHKDT^IBINUT1(IBTO,IBINSTDT)
QUIT
+11 ; IB*2.0*782
SET IBIENS=IBIEN_","
+12 ; bill status (350/.05) - external
SET IBSTATNM=$$GET1^DIQ(350,IBIENS,.05,"E")
+13 ; check bill status
+14 IF IBINFLG'="Y"
QUIT
+15 IF IBINFLG="Y"
IF "^BILLED^HOLD - RATE^HOLD - REVIEW^ON HOLD^"'[(U_IBSTATNM_U)
QUIT
+16 ; charge type (350/.03)
SET IBCHTYPE=$PIECE(IBDATA,U,3)
if IBCHTYPE=""
QUIT
+17 ; quit if LTC or Tricare charge
SET IBGRP=$PIECE(^IBE(350.1,IBCHTYPE,0),U,11)
IF IBGRP=7!(IBGRP=9)
QUIT
+18 if $$GET1^DIQ(350.1,IBCHTYPE,.05,"E")'="NEW"
QUIT
+19 ; bill #
SET IBBLNO=$PIECE(IBDATA,U,11)
+20 ; patient id and name
SET Z=$$PATID(IBDFN)
SET IBPID=$PIECE(Z,U)
SET IBNM=$PIECE(Z,U,2)
+21 ; bill amount (350/.07)
SET IBCHRG=$PIECE(IBDATA,U,7)
+22 ; "Bill From" date
SET IBFR=$PIECE(IBDATA,U,14)
+23 SET ^TMP("IBINRPT",$JOB,IBDFN,IBIEN)=IBNM_U_IBPID_U_IBINSTDT_U_IBBLNO_U_IBCHTYPE_U_IBSTATNM_U_IBFR_U_IBTO_U_IBCHRG
+24 SET ^TMP("IBINRPT",$JOB,"IDX",IBNM,IBDFN)=""
+25 QUIT
End DoDot:3
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 DO PRINT
+29 KILL ^TMP("IBINRPT",$JOB)
+30 QUIT
+31 ;
PRINT ; print report
+1 NEW EXTDT,IBCHRG,IBCHTYPE,IBDATA,IBDFN,IBNM,LN,PAGE,QUIT
+2 USE IO
+3 SET (PAGE,QUIT)=0
+4 SET EXTDT=$$FMTE^XLFDT(DT)
+5 IF EXCEL
Begin DoDot:1
+6 WRITE !,"AI/AN Verified Copay Exemption Report",U,EXTDT,U,$$FMTE^XLFDT(IBSTART),"-",$$FMTE^XLFDT(IBEND)
+7 WRITE !,"Name^ID^AI/AN Start date^Bill #^Charge type^Bill status^Bill From date^Bill To Date^Bill amount"
+8 QUIT
End DoDot:1
+9 IF 'EXCEL
Begin DoDot:1
+10 IF $EXTRACT(IOST,1,2)["C-"
IF '$DATA(ZTQUEUED)
WRITE @IOF
+11 DO HDR
+12 QUIT
End DoDot:1
+13 IF '$DATA(^TMP("IBINRPT",$JOB))
Begin DoDot:1
+14 IF EXCEL
WRITE !!,"No records found."
QUIT
+15 WRITE !!,$$CJ^XLFSTR("No records found.",132)
+16 IF PAGE>0
IF '$DATA(ZTQUEUED)
WRITE !
DO PAUSE
WRITE @IOF
+17 QUIT
End DoDot:1
QUIT
+18 SET IBNM=""
FOR
SET IBNM=$ORDER(^TMP("IBINRPT",$JOB,"IDX",IBNM))
if IBNM=""!QUIT
QUIT
Begin DoDot:1
+19 SET IBDFN=""
FOR
SET IBDFN=$ORDER(^TMP("IBINRPT",$JOB,"IDX",IBNM,IBDFN))
if IBDFN=""!QUIT
QUIT
Begin DoDot:2
+20 SET IBIEN=""
FOR
SET IBIEN=$ORDER(^TMP("IBINRPT",$JOB,IBDFN,IBIEN))
if IBIEN=""!QUIT
QUIT
Begin DoDot:3
+21 SET IBDATA=^TMP("IBINRPT",$JOB,IBDFN,IBIEN)
+22 SET IBCHTYPE=$$GET1^DIQ(350.1,$PIECE(IBDATA,U,5),.01,"E")
+23 SET IBCHRG=$FNUMBER($PIECE(IBDATA,U,9),"",2)
+24 IF EXCEL
Begin DoDot:4
+25 WRITE !,$PIECE(IBDATA,U),U,$PIECE(IBDATA,U,2),U,$$FMTE^XLFDT($PIECE(IBDATA,U,3),"2Z"),U,$PIECE(IBDATA,U,4),U,IBCHTYPE,U,$PIECE(IBDATA,U,6),U
+26 ; IB*2.0*782
WRITE $$FMTE^XLFDT($PIECE(IBDATA,U,7),"2DZ"),U,$$FMTE^XLFDT($PIECE(IBDATA,U,8),"2DZ"),U,IBCHRG
+27 QUIT
End DoDot:4
QUIT
+28 SET LN=LN+1
+29 WRITE !,$EXTRACT($PIECE(IBDATA,U),1,25),?27,$PIECE(IBDATA,U,2),?34,$$FMTE^XLFDT($PIECE(IBDATA,U,3),"2Z"),?45,$$CJ^XLFSTR($PIECE(IBDATA,U,4),12),?58
+30 ; IB*2.0*782
WRITE $EXTRACT(IBCHTYPE,1,12),?72,$$CJ^XLFSTR($PIECE(IBDATA,U,6),13),?88,$$FMTE^XLFDT($PIECE(IBDATA,U,7),"2DZ"),?99,$$FMTE^XLFDT($PIECE(IBDATA,U,8),"2DZ"),?107
+31 ; IB*2.0*782
WRITE $$CJ^XLFSTR("$"_IBCHRG,11)
+32 IF LN>(IOSL-3)
DO HDR
IF QUIT
QUIT
+33 QUIT
End DoDot:3
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 IF PAGE>0
IF '$DATA(ZTQUEUED)
IF 'QUIT
WRITE !!,$$CJ^XLFSTR("End of report.",132)
DO PAUSE
WRITE @IOF
+37 QUIT
+38 ;
HDR ; print header
+1 IF PAGE>0
IF '$DATA(ZTQUEUED)
DO PAUSE
WRITE @IOF
IF $GET(QUIT)
QUIT
+2 SET PAGE=PAGE+1
SET LN=7
+3 WRITE !,"AI/AN Verified Copay Exemption Report",?66,EXTDT,?119,"Page: ",PAGE
+4 WRITE !,"AI/AN Change dates: ",$$FMTE^XLFDT(IBSTART)," - ",$$FMTE^XLFDT(IBEND)
+5 WRITE !
+6 WRITE !," AI/AN Bill From Bill To Bill "
+7 WRITE !,"Name ID Start Date Bill # Charge Type Bill Status Date Date Amount"
+8 WRITE !
DO DASH(132)
+9 QUIT
+10 ;
DASH(LEN) ; print line of dashes
+1 NEW DASH
+2 SET $PIECE(DASH,"-",LEN+1)=""
WRITE DASH
+3 QUIT
+4 ;
PATID(DFN) ; returns Id for a given patient
+1 ;
+2 ; DFN - patient's DFN
+3 ;
+4 ; returns [first letter of the last name]_[last 4 digits of the SSN for a given patient] ^ patient name, or "" if unable to get the Id
+5 ;
+6 NEW IBNM,VADM
+7 IF +$GET(DFN)'>0
QUIT ""
+8 DO DEM^VADPT
+9 SET IBNM=VADM(1)
+10 QUIT $EXTRACT(IBNM,1)_$PIECE($PIECE(VADM(2),U,2),"-",3)_U_IBNM
+11 ;
ASKDT ; prompt for start and end dates
+1 ;
+2 ; sets IBSTART and IBEND vars to start date and end date respectively, sets QUIT=1 on user exit
+3 ;
+4 NEW DIR,DUOUT,DTOUT,DIRUT,X,Y
+5 ; IB*2.0*782
SET DIR(0)="DA^3220105:"_DT_":EX"
+6 SET DIR("A")="Start with AI/AN change date: "
+7 SET DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-7),"1D")
+8 ; IB*2.0*782
SET DIR("?",2)=" Please enter a valid start date."
+9 ; IB*2.0*782
SET DIR("?",1)=" This date must not precede 01/05/22."
+10 ; IB*2.0*782
SET DIR("?")=" This date must not be in the future."
+11 DO ^DIR
+12 IF $DATA(DIRUT)
SET QUIT=1
GOTO ASKDTX
+13 SET IBSTART=Y
+14 ; End date
ASKDT1 ;
+1 ; IB*2.0*782
SET DIR(0)="DA^"_IBSTART_":"_DT_":EX"
+2 SET DIR("A")=" End with AI/AN change date: "
+3 SET DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT),"1D")
+4 ; IB*2.0*782
SET DIR("?",2)=" Please enter a valid end date."
+5 ; IB*2.0*782
SET DIR("?",1)=" This date must not precede the start date entered above."
+6 ; IB*2.0*782
SET DIR("?")=" This date must not be in the future."
+7 DO ^DIR
+8 IF $DATA(DIRUT)
SET QUIT=1
GOTO ASKDTX
+9 SET IBEND=Y
+10 ;
ASKDTX ; dates prompt exit point
+1 QUIT
+2 ;
PAUSE ; "Type <Enter> to continue" prompt
+1 NEW DIR,DUOUT,DTOUT,DIRUT,X,Y
+2 SET DIR(0)="E"
DO ^DIR
+3 IF $DATA(DIRUT)
SET QUIT=1
+4 WRITE !
+5 QUIT
