PRCACDRP ;ALB/YG - Catastrophically Disabled Exempt Copay Charge Report; July 25, 2019@21:06
;;4.5;Accounts Receivable;**350,386,414**;Mar 20, 1995;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;
; Routine was cloned from IBOCDRPT and moved to AR (PRCA) namespace
;
;PRC*4.5*386 Uses admit date in lieu of discharge date for I/P
; Removes Urgent Care copayments as they are not auto exempt
;
EN ; - this will produce a report of patient's with charges that are CD.
;
N POP,%ZIS,ZTRTN,ZTDESC,ZTSK,IBEDT,IBBDT,%DT,ZTSAVE,IBEXCEL
W !!,"*** Print the Catastrophically Disabled Exempt Copay Charge Report ***"
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."
W !!,"This report includes bills for charges without an IB Status of Cancelled"
W !,"and with an AR Status of Active, Open, Suspended, Write-Off, Cancellation,"
W !,"Collected/Closed or with an IB Status of On-Hold, and an episode of care"
W !,"date on or after the Catastrophically Disabled exemption effective date.",!
D DATE Q:'IBEDT
S IBEXCEL=$$EXCEL^PRCACDRP()
I IBEXCEL D EXMSG
I 'IBEXCEL D
. W !!,"This report may take a while to process. It is recommended that you Queue"
. W !,"this report to a device that is 132 characters wide."
S %ZIS="QM" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
.S ZTRTN="DQ^PRCACDRP",ZTDESC="Catastrophically Disabled Copay Report"
.S ZTSAVE("IBEDT")="",ZTSAVE("IBBDT")="",ZTSAVE("IBEXCEL")=""
.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,REAS,ARSTAT,EOCDT,FUND,IBDATA,IBSTAT,MCDT,RXDT,PRGRP,CD,CDDATE,PAR,PARZ
N PRCAAR1,PRCAADMT ;PRCA*4.5*386
;
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) D Q:IBQUIT
. S IBX=0 F S IBX=$O(^IB("D",IBDDT,IBX)) Q:'IBX!(IBQUIT) D Q:IBQUIT
. . S IBZ=$G(^IB(IBX,0)),DFN=+$P(IBZ,"^",2),PRCAAR1=IBX,(PRCAADMT,PRCAAR1)="" ;PRCA*4.5*386
. . I $P(IBZ,U,16) D ;PRCA*4.5*386
. . . S PRCAAR1=$G(^IB($P(IBZ,U,16),0))
. . I +PRCAAR1,":55:56:"[(":"_+$P(PRCAAR1,U,3)_":") S PRCAADMT=$P(PRCAAR1,U,17) ;PRCA*4.5*386
. . S PRGRP=$$PRIORITY^DGENA(DFN)
. . 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))\1 S:PRCAADMT IBDT=PRCAADMT
. . K IBDG
. . S IBDG=$$GET^DGENCDA(DFN,.IBDG) ; IA# 4969
. . ; quit if no date, or pt not CD
. . S REAS=1
. . I 'IBDT Q ; no date
. . S CDDATE=IBDG("REVDTE")
. . S CD=$G(IBDG("VCD"))="Y"
. . ; Business decision is to ignore Billing Exemption file 354.1
. . ;I 'CD S CDDATE="" F S CD=$O(^IBA(354.1,"AP",DFN,CD)) Q:'CD I $P($G(^IBA(354.1,CD,0)),U,5)=12 S CD=1,CDDATE=$P(^(0),U) Q
. . I 'CD Q
. . 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,"8,77:79;141;203;255.1","IBARDATA") ; IA# 1452
. . S IBDATA=$$GETIB^RCDMCR4B(IBX,0) I +IBDATA=0 Q ; PRCA*4.5*414
. . S MCDT=$P(IBDATA,U,2) S:MCDT="" MCDT=$P(IBDATA,U,3)
. . S RXDT=$P(IBDATA,U,4)
. . S EOCDT=$S(RXDT>MCDT:RXDT,1:MCDT)
. . S IBSTAT=$P(IBDATA,U,5) S:IBSTAT="" IBSTAT=$P(IBZ,U,5)
. . S ARSTAT=$G(IBARDATA(430,IBARX,8,"E")) I ARSTAT="COLLECTED/CLOSED" S ARSTAT="C/C"
. . ; quit if status cancelled (ib) or no charge
. . I IBSTAT=10 Q ; cancelled
. . I '$P(IBZ,"^",7) Q ; no charge
. . ; quit if AR STATUS is not on the list and IB status is not ON HOLD. Question - what about CANCELLED BILL (#26)
. . S REAS=2 I IBARX,$P(IBARBILL,"^",2)=26 Q
. . ; non inpatient, only talk to parent
. . S REAS=3 I $P(IBZ,U,4)'?1"405:".E,$P(IBZ,U,4)'?1"45:".E,$$PARENTE^RCDMCR5B(IBX)'=IBX Q
. . ; inpatient, check if parent event or parent charge is cancelled.
. . I $P(IBZ,U,4)?1"405:".E!($P(IBZ,U,4)'?1"45:".E) S PAR=$$PARENTE^RCDMCR5B(IBX) I PAR S PARZ=^IB(PAR,0) I $P(PARZ,U,5)=10 Q
. . I $P(IBZ,U,4)?1"405:".E!($P(IBZ,U,4)'?1"45:".E) S PAR=$$PARENTC^RCDMCR5B(IBX) I PAR S PARZ=^IB(PAR,0) I $P(PARZ,U,5)=10 Q
. . ; quit if CD effective date not before event date
. . S REAS=4 Q:IBDT<3100505 Q:IBDT<CDDATE
. . ; quit if not within specified date range
. . S REAS=5 Q:IBDT<IBBDT!(IBDT>IBEDT) Q:EOCDT<IBBDT!(EOCDT>IBEDT)
. . ; quit if LTC action type
. . S REAS=6 I $P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^")["LTC " Q
. . S REAS=7 Q:'IBDATA
. . ; quit if not the right fund
. . S REAS=8 I IBARX S FUND=$G(IBARDATA(430,IBARX,203,"E")) I FUND'=528703,FUND'=528701 Q
. . ; quit if AR STATUS is not on the list and IB status is not ON HOLD. Question - what about CANCELLED BILL (#26)
. . S REAS=9 I '$F(",16,39,42,40,22,23,",","_$P(IBARBILL,U,2)_","),$P(IBZ,U,5)'=8 Q
. . S REAS=10 Q:EOCDT<3100505 Q:EOCDT<CDDATE
. . S IBDPT=$G(^DPT(DFN,0))
. . I PRCAADMT S MCDT=PRCAADMT ;PRCA*4.5*386
. . I 'IBEXCEL D
. . . S REAS=0 W !,$E($P(IBDPT,"^"),1,20) ; patient name
. . . W ?21,$P(IBDPT,"^",9) ; snn
. . . W ?31,PRGRP ; Priority group
. . . W ?33,$$FMTE^XLFDT($G(IBDG("REVDTE")),"2DZ") ; Catastrophically Disabled Date, IA# 10103
. . . W ?42,$E($P($P(IBZ,"^",11),"-",2),1,8) ; ar bill no
. . . W:MCDT'="" ?50,$$FMTE^XLFDT(MCDT,"2DZ") ; Med Care Date
. . . W:RXDT'="" ?59,$$FMTE^XLFDT(RXDT,"2DZ") ; RX Date
. . . W ?68,$E($P(IBDATA,U,6),1,8) ; rx #
. . . W ?77,$E($P(IBDATA,U,7),1,20) ; rx name
. . . W ?98,$J("$"_$FN($P(IBDATA,U,8),"",2),9) ; charge
. . . W ?108,$E($P($G(^IBE(350.21,IBSTAT,0)),U),1,10) ; IBSTATUS
. . . W ?119,$E(ARSTAT,1,13) ; AR Status
. . . I $Y+3>IOSL D HEAD
. . I IBEXCEL D
. . . S REAS=0 W !,"""",$P(IBDPT,"^"),"""" ; patient name
. . . W U,$P(IBDPT,"^",9) ; snn
. . . W U,PRGRP ; Priority group
. . . W U,$$FMTE^XLFDT($G(IBDG("REVDTE")),"2DZ") ; Catastrophically Disabled Date, IA# 10103
. . . W U,$P($P(IBZ,"^",11),"-",2) ; ar bill no
. . . W U W:MCDT'="" $$FMTE^XLFDT(MCDT,"2DZ") ; Med Care Date
. . . W U W:RXDT'="" $$FMTE^XLFDT(RXDT,"2DZ") ; RX Date
. . . W U,$P(IBDATA,U,6) ; rx # (or get it from IBDATA?)
. . . W U,$P(IBDATA,U,7) ; rx name
. . . W U,"$",$FN($P(IBDATA,U,8),"",2) ; charge
. . . W U,$P($G(^IBE(350.21,IBSTAT,0)),U) ; IBSTATUS
. . . W U,ARSTAT ; AR Status
I 'IBQUIT,'IBEXCEL,IBP,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I $D(DIRUT) S IBQUIT=1 Q
D ^%ZISC
EXIT S:$D(ZTQUEUED) ZTREQ="@"
Q
HEAD ;
N IBL,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
I 'IBEXCEL,IBP,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I $D(DIRUT) S IBQUIT=1 Q
S IBP=IBP+1
I 'IBEXCEL D
. W @IOF,!,"Cross-Servicing Catastrophically Disabled Exempt Copayment Charge Report --- Run Date: ",$$FMTE^XLFDT($$NOW^XLFDT,"9MP")," ---",?122,"Page: ",IBP
. W !,"Episode of Care Dates from ",$$FMTE^XLFDT(IBBDT,"9MP")," to ",$$FMTE^XLFDT(IBEDT,"9MP")
. W !," Pri CD Medical RX Fill Charge"
. W !,"Patient Name SSN Grp Date Bill NO Care Date Date RX # RX Name Amount IB Status AR Status",!
I IBEXCEL D
. W !,"Patient Name",U,"SSN",U,"Pri Grp",U,"CD Date",U,"Bill NO",U,"Medical Care Date",U,"RX Fill Date",U,"RX #",U
. W "RX Name",U,"Charge Amount",U,"IB Status",U,"AR Status",U
I 'IBEXCEL F IBL=1:1:$S(IOM:IOM,1:132) W "-"
Q
EXCEL() ; Export the report to MS Excel?
; Function return values:
; 0 - User selected "No" at prompt.
; 1 - User selected "Yes" at prompt.
; ^ - User aborted.
; This function allows the user to indicate whether the report should be
; printed in a format that could easily be imported into an Excel
; spreadsheet. If the user wants to print in EXCEL format, the variable
; IBEXCEL will be set to '1', otherwise IBEXCEL will be set to '0' for "No"
; or "^" to abort.
;
N DIR,DIRUT,Y
S DIR(0)="Y"
S DIR("A")="Do you want to capture report data for an Excel document"
I $G(IBEXCEL)=1 S DIR("B")="YES"
E S DIR("B")="NO"
S DIR("?",1)="If you want to capture the output from this report in a format that"
S DIR("?",2)="could easily be imported into an Excel spreadsheet, then answer YES here."
S DIR("?")="If you want a normal report output, then answer NO here."
W !
D ^DIR
K DIR
I $D(DIRUT) Q "^" ; Abort
Q +Y
DATE ;
; -get beginning and ending dates
; -output in ibbdt - beginning date
; ibedt - ending date
;
BDT ; -get beginning date
S (IBBDT,IBEDT)=""
;S %DT(0)=3100505
S %DT("B")="May 5, 2010"
S %DT="AEX",%DT("A")="Start with DATE: " D ^%DT K %DT G DATEQ:Y<0
S IBBDT=Y
I IBBDT<3100505 S IBBDT=3100505 ;W !,"Start date changed to 5/5/2010"
;
EDT ; -get ending date
S %DT="AEX",%DT("A")="Go to DATE: ",%DT("B")="T" D ^%DT S:X=" " X=IBBDT
G DATEQ:(X="")!(X["^") G EDT:Y<0
S IBEDT=Y I Y<IBBDT W *7," ??",!,"ENDING DATE must follow BEGINNING DATE." G BDT
;
DATEQ K %DT
Q
EXMSG ;
W !,"This report may take a while to process. To capture as an Excel"
W !,"format, it is recommended that you queue this report to a spool device"
W !,"with margins of 256 and page length of 99999 (e.g. spoolname;256;99999)."
W !,"This should help avoid wrapping problems."
W !!,"Another method would be to set up your terminal to capture the detail"
W !,"report data. On some terminals, this can be done by clicking on the "
W !,"'Tools' menu above, then click on 'Capture Incoming Data' to save to"
W !,"Desktop. To avoid undesired wrapping of the data saved to the file,"
W !,"please enter '0;256;99999' at the 'DEVICE:' prompt."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCACDRP 9879 printed Nov 22, 2024@16:49:23 Page 2
PRCACDRP ;ALB/YG - Catastrophically Disabled Exempt Copay Charge Report; July 25, 2019@21:06
+1 ;;4.5;Accounts Receivable;**350,386,414**;Mar 20, 1995;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Routine was cloned from IBOCDRPT and moved to AR (PRCA) namespace
+5 ;
+6 ;PRC*4.5*386 Uses admit date in lieu of discharge date for I/P
+7 ; Removes Urgent Care copayments as they are not auto exempt
+8 ;
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,IBEXCEL
+3 WRITE !!,"*** Print the Catastrophically Disabled Exempt Copay Charge Report ***"
+4 WRITE !!,"The Catastrophically Disabled legislation effective date is May 5, 2010."
+5 WRITE !,"You should not enter a date prior to that date, any date entered before"
+6 WRITE !,"that will be automatically changed to May 5, 2010."
+7 WRITE !!,"This report includes bills for charges without an IB Status of Cancelled"
+8 WRITE !,"and with an AR Status of Active, Open, Suspended, Write-Off, Cancellation,"
+9 WRITE !,"Collected/Closed or with an IB Status of On-Hold, and an episode of care"
+10 WRITE !,"date on or after the Catastrophically Disabled exemption effective date.",!
+11 DO DATE
if 'IBEDT
QUIT
+12 SET IBEXCEL=$$EXCEL^PRCACDRP()
+13 IF IBEXCEL
DO EXMSG
+14 IF 'IBEXCEL
Begin DoDot:1
+15 WRITE !!,"This report may take a while to process. It is recommended that you Queue"
+16 WRITE !,"this report to a device that is 132 characters wide."
End DoDot:1
+17 SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+18 IF $DATA(IO("Q"))
Begin DoDot:1
+19 SET ZTRTN="DQ^PRCACDRP"
SET ZTDESC="Catastrophically Disabled Copay Report"
+20 SET ZTSAVE("IBEDT")=""
SET ZTSAVE("IBBDT")=""
SET ZTSAVE("IBEXCEL")=""
+21 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
+22 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,REAS,ARSTAT,EOCDT,FUND,IBDATA,IBSTAT,MCDT,RXDT,PRGRP,CD,CDDATE,PAR,PARZ
+3 ;PRCA*4.5*386
NEW PRCAAR1,PRCAADMT
+4 ;
+5 SET (IBP,IBQUIT)=0
+6 DO HEAD
+7 ; not before CD effective date
IF IBBDT<3100505
SET IBBDT=3100505
+8 SET IBDDT=IBBDT-1
FOR
SET IBDDT=$ORDER(^IB("D",IBDDT))
if 'IBDDT!(IBQUIT)
QUIT
Begin DoDot:1
+9 SET IBX=0
FOR
SET IBX=$ORDER(^IB("D",IBDDT,IBX))
if 'IBX!(IBQUIT)
QUIT
Begin DoDot:2
+10 ;PRCA*4.5*386
SET IBZ=$GET(^IB(IBX,0))
SET DFN=+$PIECE(IBZ,"^",2)
SET PRCAAR1=IBX
SET (PRCAADMT,PRCAAR1)=""
+11 ;PRCA*4.5*386
IF $PIECE(IBZ,U,16)
Begin DoDot:3
+12 SET PRCAAR1=$GET(^IB($PIECE(IBZ,U,16),0))
End DoDot:3
+13 ;PRCA*4.5*386
IF +PRCAAR1
IF ":55:56:"[(":"_+$PIECE(PRCAAR1,U,3)_":")
SET PRCAADMT=$PIECE(PRCAAR1,U,17)
+14 SET PRGRP=$$PRIORITY^DGENA(DFN)
+15 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))\1
if PRCAADMT
SET IBDT=PRCAADMT
+16 KILL IBDG
+17 ; IA# 4969
SET IBDG=$$GET^DGENCDA(DFN,.IBDG)
+18 ; quit if no date, or pt not CD
+19 SET REAS=1
+20 ; no date
IF 'IBDT
QUIT
+21 SET CDDATE=IBDG("REVDTE")
+22 SET CD=$GET(IBDG("VCD"))="Y"
+23 ; Business decision is to ignore Billing Exemption file 354.1
+24 ;I 'CD S CDDATE="" F S CD=$O(^IBA(354.1,"AP",DFN,CD)) Q:'CD I $P($G(^IBA(354.1,CD,0)),U,5)=12 S CD=1,CDDATE=$P(^(0),U) Q
+25 IF 'CD
QUIT
+26 ; IA# 389
SET IBARX=+$ORDER(^PRCA(430,"B",$SELECT($PIECE(IBZ,"^",11):$PIECE(IBZ,"^",11),1:0),0))
+27 ; IA# 1452
SET IBARBILL=$SELECT(IBARX:$$BILL^RCJIBFN2(IBARX),1:"")
+28 KILL IBARDATA
+29 ; IA# 1452
IF IBARX
DO DIQ^RCJIBFN2(IBARX,"8,77:79;141;203;255.1","IBARDATA")
+30 ; PRCA*4.5*414
SET IBDATA=$$GETIB^RCDMCR4B(IBX,0)
IF +IBDATA=0
QUIT
+31 SET MCDT=$PIECE(IBDATA,U,2)
if MCDT=""
SET MCDT=$PIECE(IBDATA,U,3)
+32 SET RXDT=$PIECE(IBDATA,U,4)
+33 SET EOCDT=$SELECT(RXDT>MCDT:RXDT,1:MCDT)
+34 SET IBSTAT=$PIECE(IBDATA,U,5)
if IBSTAT=""
SET IBSTAT=$PIECE(IBZ,U,5)
+35 SET ARSTAT=$GET(IBARDATA(430,IBARX,8,"E"))
IF ARSTAT="COLLECTED/CLOSED"
SET ARSTAT="C/C"
+36 ; quit if status cancelled (ib) or no charge
+37 ; cancelled
IF IBSTAT=10
QUIT
+38 ; no charge
IF '$PIECE(IBZ,"^",7)
QUIT
+39 ; quit if AR STATUS is not on the list and IB status is not ON HOLD. Question - what about CANCELLED BILL (#26)
+40 SET REAS=2
IF IBARX
IF $PIECE(IBARBILL,"^",2)=26
QUIT
+41 ; non inpatient, only talk to parent
+42 SET REAS=3
IF $PIECE(IBZ,U,4)'?1"405:".E
IF $PIECE(IBZ,U,4)'?1"45:".E
IF $$PARENTE^RCDMCR5B(IBX)'=IBX
QUIT
+43 ; inpatient, check if parent event or parent charge is cancelled.
+44 IF $PIECE(IBZ,U,4)?1"405:".E!($PIECE(IBZ,U,4)'?1"45:".E)
SET PAR=$$PARENTE^RCDMCR5B(IBX)
IF PAR
SET PARZ=^IB(PAR,0)
IF $PIECE(PARZ,U,5)=10
QUIT
+45 IF $PIECE(IBZ,U,4)?1"405:".E!($PIECE(IBZ,U,4)'?1"45:".E)
SET PAR=$$PARENTC^RCDMCR5B(IBX)
IF PAR
SET PARZ=^IB(PAR,0)
IF $PIECE(PARZ,U,5)=10
QUIT
+46 ; quit if CD effective date not before event date
+47 SET REAS=4
if IBDT<3100505
QUIT
if IBDT<CDDATE
QUIT
+48 ; quit if not within specified date range
+49 SET REAS=5
if IBDT<IBBDT!(IBDT>IBEDT)
QUIT
if EOCDT<IBBDT!(EOCDT>IBEDT)
QUIT
+50 ; quit if LTC action type
+51 SET REAS=6
IF $PIECE($GET(^IBE(350.1,+$PIECE(IBZ,"^",3),0)),"^")["LTC "
QUIT
+52 SET REAS=7
if 'IBDATA
QUIT
+53 ; quit if not the right fund
+54 SET REAS=8
IF IBARX
SET FUND=$GET(IBARDATA(430,IBARX,203,"E"))
IF FUND'=528703
IF FUND'=528701
QUIT
+55 ; quit if AR STATUS is not on the list and IB status is not ON HOLD. Question - what about CANCELLED BILL (#26)
+56 SET REAS=9
IF '$FIND(",16,39,42,40,22,23,",","_$PIECE(IBARBILL,U,2)_",")
IF $PIECE(IBZ,U,5)'=8
QUIT
+57 SET REAS=10
if EOCDT<3100505
QUIT
if EOCDT<CDDATE
QUIT
+58 SET IBDPT=$GET(^DPT(DFN,0))
+59 ;PRCA*4.5*386
IF PRCAADMT
SET MCDT=PRCAADMT
+60 IF 'IBEXCEL
Begin DoDot:3
+61 ; patient name
SET REAS=0
WRITE !,$EXTRACT($PIECE(IBDPT,"^"),1,20)
+62 ; snn
WRITE ?21,$PIECE(IBDPT,"^",9)
+63 ; Priority group
WRITE ?31,PRGRP
+64 ; Catastrophically Disabled Date, IA# 10103
WRITE ?33,$$FMTE^XLFDT($GET(IBDG("REVDTE")),"2DZ")
+65 ; ar bill no
WRITE ?42,$EXTRACT($PIECE($PIECE(IBZ,"^",11),"-",2),1,8)
+66 ; Med Care Date
if MCDT'=""
WRITE ?50,$$FMTE^XLFDT(MCDT,"2DZ")
+67 ; RX Date
if RXDT'=""
WRITE ?59,$$FMTE^XLFDT(RXDT,"2DZ")
+68 ; rx #
WRITE ?68,$EXTRACT($PIECE(IBDATA,U,6),1,8)
+69 ; rx name
WRITE ?77,$EXTRACT($PIECE(IBDATA,U,7),1,20)
+70 ; charge
WRITE ?98,$JUSTIFY("$"_$FNUMBER($PIECE(IBDATA,U,8),"",2),9)
+71 ; IBSTATUS
WRITE ?108,$EXTRACT($PIECE($GET(^IBE(350.21,IBSTAT,0)),U),1,10)
+72 ; AR Status
WRITE ?119,$EXTRACT(ARSTAT,1,13)
+73 IF $Y+3>IOSL
DO HEAD
End DoDot:3
+74 IF IBEXCEL
Begin DoDot:3
+75 ; patient name
SET REAS=0
WRITE !,"""",$PIECE(IBDPT,"^"),""""
+76 ; snn
WRITE U,$PIECE(IBDPT,"^",9)
+77 ; Priority group
WRITE U,PRGRP
+78 ; Catastrophically Disabled Date, IA# 10103
WRITE U,$$FMTE^XLFDT($GET(IBDG("REVDTE")),"2DZ")
+79 ; ar bill no
WRITE U,$PIECE($PIECE(IBZ,"^",11),"-",2)
+80 ; Med Care Date
WRITE U
if MCDT'=""
WRITE $$FMTE^XLFDT(MCDT,"2DZ")
+81 ; RX Date
WRITE U
if RXDT'=""
WRITE $$FMTE^XLFDT(RXDT,"2DZ")
+82 ; rx # (or get it from IBDATA?)
WRITE U,$PIECE(IBDATA,U,6)
+83 ; rx name
WRITE U,$PIECE(IBDATA,U,7)
+84 ; charge
WRITE U,"$",$FNUMBER($PIECE(IBDATA,U,8),"",2)
+85 ; IBSTATUS
WRITE U,$PIECE($GET(^IBE(350.21,IBSTAT,0)),U)
+86 ; AR Status
WRITE U,ARSTAT
End DoDot:3
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+87 IF 'IBQUIT
IF 'IBEXCEL
IF IBP
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+88 DO ^%ZISC
EXIT if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 QUIT
HEAD ;
+1 NEW IBL,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 IF 'IBEXCEL
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 IF 'IBEXCEL
Begin DoDot:1
+5 WRITE @IOF,!,"Cross-Servicing Catastrophically Disabled Exempt Copayment Charge Report --- Run Date: ",$$FMTE^XLFDT($$NOW^XLFDT,"9MP")," ---",?122,"Page: ",IBP
+6 WRITE !,"Episode of Care Dates from ",$$FMTE^XLFDT(IBBDT,"9MP")," to ",$$FMTE^XLFDT(IBEDT,"9MP")
+7 WRITE !," Pri CD Medical RX Fill Charge"
+8 WRITE !,"Patient Name SSN Grp Date Bill NO Care Date Date RX # RX Name Amount IB Status AR Status",!
End DoDot:1
+9 IF IBEXCEL
Begin DoDot:1
+10 WRITE !,"Patient Name",U,"SSN",U,"Pri Grp",U,"CD Date",U,"Bill NO",U,"Medical Care Date",U,"RX Fill Date",U,"RX #",U
+11 WRITE "RX Name",U,"Charge Amount",U,"IB Status",U,"AR Status",U
End DoDot:1
+12 IF 'IBEXCEL
FOR IBL=1:1:$SELECT(IOM:IOM,1:132)
WRITE "-"
+13 QUIT
EXCEL() ; Export the report to MS Excel?
+1 ; Function return values:
+2 ; 0 - User selected "No" at prompt.
+3 ; 1 - User selected "Yes" at prompt.
+4 ; ^ - User aborted.
+5 ; This function allows the user to indicate whether the report should be
+6 ; printed in a format that could easily be imported into an Excel
+7 ; spreadsheet. If the user wants to print in EXCEL format, the variable
+8 ; IBEXCEL will be set to '1', otherwise IBEXCEL will be set to '0' for "No"
+9 ; or "^" to abort.
+10 ;
+11 NEW DIR,DIRUT,Y
+12 SET DIR(0)="Y"
+13 SET DIR("A")="Do you want to capture report data for an Excel document"
+14 IF $GET(IBEXCEL)=1
SET DIR("B")="YES"
+15 IF '$TEST
SET DIR("B")="NO"
+16 SET DIR("?",1)="If you want to capture the output from this report in a format that"
+17 SET DIR("?",2)="could easily be imported into an Excel spreadsheet, then answer YES here."
+18 SET DIR("?")="If you want a normal report output, then answer NO here."
+19 WRITE !
+20 DO ^DIR
+21 KILL DIR
+22 ; Abort
IF $DATA(DIRUT)
QUIT "^"
+23 QUIT +Y
DATE ;
+1 ; -get beginning and ending dates
+2 ; -output in ibbdt - beginning date
+3 ; ibedt - ending date
+4 ;
BDT ; -get beginning date
+1 SET (IBBDT,IBEDT)=""
+2 ;S %DT(0)=3100505
+3 SET %DT("B")="May 5, 2010"
+4 SET %DT="AEX"
SET %DT("A")="Start with DATE: "
DO ^%DT
KILL %DT
if Y<0
GOTO DATEQ
+5 SET IBBDT=Y
+6 ;W !,"Start date changed to 5/5/2010"
IF IBBDT<3100505
SET IBBDT=3100505
+7 ;
EDT ; -get ending date
+1 SET %DT="AEX"
SET %DT("A")="Go to DATE: "
SET %DT("B")="T"
DO ^%DT
if X=" "
SET X=IBBDT
+2 if (X="")!(X["^")
GOTO DATEQ
if Y<0
GOTO EDT
+3 SET IBEDT=Y
IF Y<IBBDT
WRITE *7," ??",!,"ENDING DATE must follow BEGINNING DATE."
GOTO BDT
+4 ;
DATEQ KILL %DT
+1 QUIT
EXMSG ;
+1 WRITE !,"This report may take a while to process. To capture as an Excel"
+2 WRITE !,"format, it is recommended that you queue this report to a spool device"
+3 WRITE !,"with margins of 256 and page length of 99999 (e.g. spoolname;256;99999)."
+4 WRITE !,"This should help avoid wrapping problems."
+5 WRITE !!,"Another method would be to set up your terminal to capture the detail"
+6 WRITE !,"report data. On some terminals, this can be done by clicking on the "
+7 WRITE !,"'Tools' menu above, then click on 'Capture Incoming Data' to save to"
+8 WRITE !,"Desktop. To avoid undesired wrapping of the data saved to the file,"
+9 WRITE !,"please enter '0;256;99999' at the 'DEVICE:' prompt."
+10 QUIT
