IBOCDRPT ;ELZ/OAK - CATASTROPHICALLY DISABLED PATIENT BILLING ;03/21/2011
;;2.0;INTEGRATED BILLING;**449,618**;21-MAR-94;Build 61
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
EN ; - this will produce a report of patient's with charges that are CD.
;
N POP,%ZIS,ZTRTN,ZTDESC,ZTSK,IBEDT,IBBDT,%DT,ZTSAVE
W !,"The Catastrophically Disabled legislation effective date is May 5, 2010."
W !,"You should not enter a date prior to that date, any date entered before"
W !,"that will be automatically changed to May 5, 2010."
S %DT(0)=3100505,%DT("B")="May 5, 2010"
D DATE^IBOUTL Q:'IBEDT
;
W !!,"Select the device for the Catastrophically Disabled Charge report. It"
W !,"should be queued to a printer off hours as it can take some time to run"
W !,"with at least a margin of 132 columns."
S %ZIS="QM" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
.S ZTRTN="DQ^IBOCDRPT",ZTDESC="Catastrophically Disabled Copay Report"
.S (ZTSAVE("IBEDT"),ZTSAVE("IBBDT"))=""
.D ^%ZTLOAD D HOME^%ZIS K IO("Q")
.D MES^XPDUTL("Catastrophically Disabled Copay Report queued #"_ZTSK)
DQ U IO
;
N IBX,IBZ,IBDT,IBDG,DFN,IBP,IBARX,IBARBILL,IBARDATA,IBDPT,IBDDT,IBQUIT
;
S (IBP,IBQUIT)=0
D HEAD
I IBBDT<3100505 S IBBDT=3100505 ; not before CD effective date
S IBDDT=IBBDT-1 F S IBDDT=$O(^IB("D",IBDDT)) Q:'IBDDT!(IBQUIT) S IBX=0 F S IBX=$O(^IB("D",IBDDT,IBX)) Q:'IBX!(IBQUIT) D
. S IBZ=$G(^IB(IBX,0)),DFN=+$P(IBZ,"^",2)
. S IBDT=$S($E($P(IBZ,"^",4),1,2)=52:IBDDT,$P(IBZ,"^",8)="RX COPAYMENT":IBDDT,$P(IBZ,"^",15):$P(IBZ,"^",15),1:$P(IBZ,"^",14))
. K IBDG
. S IBDG=$$GET^DGENCDA(DFN,.IBDG) ; IA# 4969
. S IBARX=+$O(^PRCA(430,"B",$S($P(IBZ,"^",11):$P(IBZ,"^",11),1:0),0)) ; IA# 389
. S IBARBILL=$S(IBARX:$$BILL^RCJIBFN2(IBARX),1:"") ; IA# 1452
. K IBARDATA
. I IBARX D DIQ^RCJIBFN2(IBARX,"77:79;141;203;255.1","IBARDATA") ; IA# 1452
. ;
. ; quit if no date, status cancelled (ib) or pt not CD, or no charge
. Q:'IBDT!($P(IBZ,"^",5)=10)!($G(IBDG("VCD"))'="Y")!('$P(IBZ,"^",7))
. ; quit if cancelled in AR (if passed)
. I IBARX,$P(IBARBILL,"^",2)=26 Q
. ; quit if CD effective date not before event date
. Q:IBDT<3100505!(IBDT<$G(IBDG("DATE")))
. ; quit if not within specified date range
. Q:IBDT<IBBDT!($P(IBDT,".")>(IBEDT+1))
. ;IB*2.0*618 - modified LTC check to include new LTC patients
. ; quit if LTC inpatient
. Q:'$$LTCCHK(IBZ)
. ;
. S IBDPT=$G(^DPT(DFN,0))
. W !,$E($P(IBDPT,"^"),1,20) ; patient name
. W ?22,$E($P(IBDPT,"^",9),6,9) ; last 4 snn
. W ?27,$$FMTE^XLFDT($G(IBDG("DATE")),"2DZ") ; Catastrophically Disabled Date, IA# 10103
. W ?36,$$FMTE^XLFDT(IBDT,"2DZ") ; date of service, IA# 10103
. W:$E($P(IBZ,"^",4),1,2)=52 ?45,$E($P($P(IBZ,"^",8),"-"),1,11) ; rx
. W ?57,$E($P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^"),1,9) ; action type
. W ?67,$E($P($P(IBZ,"^",11),"-",2),1,8) ; ar bill no
. W ?76,$E($P($G(^IBE(350.21,+$P(IBZ,"^",5),0)),"^"),1,8) ; 350 status
. W ?85,$J($FN($P(IBARBILL,"^",3),"",2),7) ; current balance
. W ?93,$J($FN($G(IBARDATA(430,IBARX,77,"E")),"",2),7) ; pd principal
. W ?101,$J($FN($G(IBARDATA(430,IBARX,78,"E")),"",2),5) ; pd int
. W ?107,$J($FN($G(IBARDATA(430,IBARX,79,"E")),"",2),5) ; pd admin
. W ?113,$$FMTE^XLFDT($G(IBARDATA(430,IBARX,141,"I")),"2DZ") ; IA# 10103
. W ?122,$E($G(IBARDATA(430,IBARX,203,"E")),1,6)
. W ?129,$E($G(IBARDATA(430,IBARX,255.1,"E")),1,4)
. I $Y+3>IOSL D HEAD
;
D ^%ZISC
EXIT S:$D(ZTQUEUED) ZTREQ="@"
Q
;
;IB*2.0*618 Converted LTC check to a function call to allow ability to
; look for new CC LTC Action Types.
LTCCHK(IBZ) ; Check for all LTC Action Types. Return 1 if Action Type is LTC, 0 if not.
N IBLTCNM
S IBLTCNM=$P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^")
Q:IBLTCNM["DG LTC INPT" 1
Q:IBLTCNM["DG LTC FEE INPT" 1
Q:IBLTCNM["LTC CHOICE INPT" 1
Q:IBLTCNM["LTC CC INPT" 1
Q:IBLTCNM["LTC CCN INPT" 1
Q 0
;
HEAD ;
N IBL,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
I IBP,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I $D(DIRUT) S IBQUIT=1 Q
S IBP=IBP+1
W @IOF,!,"Catastrophically Disabled Copayment Charge Report PAGE: ",IBP,!
W "PATIENT SSN CD DATE DOS RX TYPE BILL NO STATUS BALANCE PD PRIN INT ADM TOP FUND RSC",!
F IBL=1:1:$S(IOM:IOM,1:132) W "-"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOCDRPT 4349 printed Oct 16, 2024@18:25:56 Page 2
IBOCDRPT ;ELZ/OAK - CATASTROPHICALLY DISABLED PATIENT BILLING ;03/21/2011
+1 ;;2.0;INTEGRATED BILLING;**449,618**;21-MAR-94;Build 61
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
EN ; - this will produce a report of patient's with charges that are CD.
+1 ;
+2 NEW POP,%ZIS,ZTRTN,ZTDESC,ZTSK,IBEDT,IBBDT,%DT,ZTSAVE
+3 WRITE !,"The Catastrophically Disabled legislation effective date is May 5, 2010."
+4 WRITE !,"You should not enter a date prior to that date, any date entered before"
+5 WRITE !,"that will be automatically changed to May 5, 2010."
+6 SET %DT(0)=3100505
SET %DT("B")="May 5, 2010"
+7 DO DATE^IBOUTL
if 'IBEDT
QUIT
+8 ;
+9 WRITE !!,"Select the device for the Catastrophically Disabled Charge report. It"
+10 WRITE !,"should be queued to a printer off hours as it can take some time to run"
+11 WRITE !,"with at least a margin of 132 columns."
+12 SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+13 IF $DATA(IO("Q"))
Begin DoDot:1
+14 SET ZTRTN="DQ^IBOCDRPT"
SET ZTDESC="Catastrophically Disabled Copay Report"
+15 SET (ZTSAVE("IBEDT"),ZTSAVE("IBBDT"))=""
+16 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
+17 DO MES^XPDUTL("Catastrophically Disabled Copay Report queued #"_ZTSK)
End DoDot:1
QUIT
DQ USE IO
+1 ;
+2 NEW IBX,IBZ,IBDT,IBDG,DFN,IBP,IBARX,IBARBILL,IBARDATA,IBDPT,IBDDT,IBQUIT
+3 ;
+4 SET (IBP,IBQUIT)=0
+5 DO HEAD
+6 ; not before CD effective date
IF IBBDT<3100505
SET IBBDT=3100505
+7 SET IBDDT=IBBDT-1
FOR
SET IBDDT=$ORDER(^IB("D",IBDDT))
if 'IBDDT!(IBQUIT)
QUIT
SET IBX=0
FOR
SET IBX=$ORDER(^IB("D",IBDDT,IBX))
if 'IBX!(IBQUIT)
QUIT
Begin DoDot:1
+8 SET IBZ=$GET(^IB(IBX,0))
SET DFN=+$PIECE(IBZ,"^",2)
+9 SET IBDT=$SELECT($EXTRACT($PIECE(IBZ,"^",4),1,2)=52:IBDDT,$PIECE(IBZ,"^",8)="RX COPAYMENT":IBDDT,$PIECE(IBZ,"^",15):$PIECE(IBZ,"^",15),1:$PIECE(IBZ,"^",14))
+10 KILL IBDG
+11 ; IA# 4969
SET IBDG=$$GET^DGENCDA(DFN,.IBDG)
+12 ; IA# 389
SET IBARX=+$ORDER(^PRCA(430,"B",$SELECT($PIECE(IBZ,"^",11):$PIECE(IBZ,"^",11),1:0),0))
+13 ; IA# 1452
SET IBARBILL=$SELECT(IBARX:$$BILL^RCJIBFN2(IBARX),1:"")
+14 KILL IBARDATA
+15 ; IA# 1452
IF IBARX
DO DIQ^RCJIBFN2(IBARX,"77:79;141;203;255.1","IBARDATA")
+16 ;
+17 ; quit if no date, status cancelled (ib) or pt not CD, or no charge
+18 if 'IBDT!($PIECE(IBZ,"^",5)=10)!($GET(IBDG("VCD"))'="Y")!('$PIECE(IBZ,"^",7))
QUIT
+19 ; quit if cancelled in AR (if passed)
+20 IF IBARX
IF $PIECE(IBARBILL,"^",2)=26
QUIT
+21 ; quit if CD effective date not before event date
+22 if IBDT<3100505!(IBDT<$GET(IBDG("DATE")))
QUIT
+23 ; quit if not within specified date range
+24 if IBDT<IBBDT!($PIECE(IBDT,".")>(IBEDT+1))
QUIT
+25 ;IB*2.0*618 - modified LTC check to include new LTC patients
+26 ; quit if LTC inpatient
+27 if '$$LTCCHK(IBZ)
QUIT
+28 ;
+29 SET IBDPT=$GET(^DPT(DFN,0))
+30 ; patient name
WRITE !,$EXTRACT($PIECE(IBDPT,"^"),1,20)
+31 ; last 4 snn
WRITE ?22,$EXTRACT($PIECE(IBDPT,"^",9),6,9)
+32 ; Catastrophically Disabled Date, IA# 10103
WRITE ?27,$$FMTE^XLFDT($GET(IBDG("DATE")),"2DZ")
+33 ; date of service, IA# 10103
WRITE ?36,$$FMTE^XLFDT(IBDT,"2DZ")
+34 ; rx
if $EXTRACT($PIECE(IBZ,"^",4),1,2)=52
WRITE ?45,$EXTRACT($PIECE($PIECE(IBZ,"^",8),"-"),1,11)
+35 ; action type
WRITE ?57,$EXTRACT($PIECE($GET(^IBE(350.1,+$PIECE(IBZ,"^",3),0)),"^"),1,9)
+36 ; ar bill no
WRITE ?67,$EXTRACT($PIECE($PIECE(IBZ,"^",11),"-",2),1,8)
+37 ; 350 status
WRITE ?76,$EXTRACT($PIECE($GET(^IBE(350.21,+$PIECE(IBZ,"^",5),0)),"^"),1,8)
+38 ; current balance
WRITE ?85,$JUSTIFY($FNUMBER($PIECE(IBARBILL,"^",3),"",2),7)
+39 ; pd principal
WRITE ?93,$JUSTIFY($FNUMBER($GET(IBARDATA(430,IBARX,77,"E")),"",2),7)
+40 ; pd int
WRITE ?101,$JUSTIFY($FNUMBER($GET(IBARDATA(430,IBARX,78,"E")),"",2),5)
+41 ; pd admin
WRITE ?107,$JUSTIFY($FNUMBER($GET(IBARDATA(430,IBARX,79,"E")),"",2),5)
+42 ; IA# 10103
WRITE ?113,$$FMTE^XLFDT($GET(IBARDATA(430,IBARX,141,"I")),"2DZ")
+43 WRITE ?122,$EXTRACT($GET(IBARDATA(430,IBARX,203,"E")),1,6)
+44 WRITE ?129,$EXTRACT($GET(IBARDATA(430,IBARX,255.1,"E")),1,4)
+45 IF $Y+3>IOSL
DO HEAD
End DoDot:1
+46 ;
+47 DO ^%ZISC
EXIT if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 QUIT
+2 ;
+3 ;IB*2.0*618 Converted LTC check to a function call to allow ability to
+4 ; look for new CC LTC Action Types.
LTCCHK(IBZ) ; Check for all LTC Action Types. Return 1 if Action Type is LTC, 0 if not.
+1 NEW IBLTCNM
+2 SET IBLTCNM=$PIECE($GET(^IBE(350.1,+$PIECE(IBZ,"^",3),0)),"^")
+3 if IBLTCNM["DG LTC INPT"
QUIT 1
+4 if IBLTCNM["DG LTC FEE INPT"
QUIT 1
+5 if IBLTCNM["LTC CHOICE INPT"
QUIT 1
+6 if IBLTCNM["LTC CC INPT"
QUIT 1
+7 if IBLTCNM["LTC CCN INPT"
QUIT 1
+8 QUIT 0
+9 ;
HEAD ;
+1 NEW IBL,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 IF IBP
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+3 SET IBP=IBP+1
+4 WRITE @IOF,!,"Catastrophically Disabled Copayment Charge Report PAGE: ",IBP,!
+5 WRITE "PATIENT SSN CD DATE DOS RX TYPE BILL NO STATUS BALANCE PD PRIN INT ADM TOP FUND RSC",!
+6 FOR IBL=1:1:$SELECT(IOM:IOM,1:132)
WRITE "-"
+7 QUIT
