PRCAWOF ;WASH-ISC@ALTOONA,PA/RGY-AR WRITE-OFF REPORT ;8/23/95 9:00 AM
V ;;4.5;Accounts Receivable;**20*,104*;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
NEW BEG,DIR,DIROUT,DIRUT,DTOUT,DUOUT,END,IOS,X,Y,%DT,%ZIS,ZTSK
BEG ;
W ! D NOW^%DTC S %DT(0)=-%,%DT="AEXP",%DT("A")="Starting Date: " D ^%DT G:Y<0 Q S BEG=Y
S %DT="AEX",%DT("A")=" Ending Date: " D ^%DT G:Y<0 Q S END=Y
I BEG>END W !!,*7,"*** Beginning date is Greater than or equal to Ending date ***",! G BEG
S %ZIS="MQ" D ^%ZIS G:POP Q
I $D(IO("Q")) S ZTRTN="DQ^PRCAWOF",ZTSAVE("BEG")="",ZTSAVE("END")="",ZTDESC="Write-Off Report" D ^%ZTLOAD G Q
U IO D DQ
Q D ^%ZISC Q
DQ ;
NEW DATE,DEBT,BILL,PAGE,PRI
S (DEBT,PAGE)=0
W:$E(IOST)="C" @IOF D HDR1
F S DEBT=$O(^PRCA(433,"ATD",DEBT)) Q:'DEBT S PRI=1 F DATE=BEG-.0001:0 S DATE=$O(^PRCA(433,"ATD",DEBT,DATE)) Q:DATE>(END+.9999)!'DATE F TRAN=0:0 S TRAN=$O(^PRCA(433,"ATD",DEBT,DATE,TRAN)) Q:'TRAN D
. I $G(^RCD(340,+DEBT,0))'["DPT" Q
. I ","_$O(^PRCA(430.3,"AC",2,0))_","_$O(^PRCA(430.3,"AC",20,0))_","'[(","_$P($G(^PRCA(433,TRAN,1)),"^",2)_",") Q
. I PRI F BILL=0:0 S BILL=$O(^PRCA(430,"C",DEBT,BILL)) Q:'BILL D Q:DEBT="Z"
.. I $P($G(^PRCA(430,BILL,0)),"^",8)'=$O(^PRCA(430.3,"AC",109,0)) G Q2
.. I PRI D:$Y+5>IOSL HDR G:DEBT="Z" Q2 W !,$P($G(^DPT(+$P(^RCD(340,DEBT,0),"^"),0)),"^") S X=$P(^(0),"^",9) W " (",$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9),")" S PRI=0
.. D:$Y+5>IOSL HDR G:DEBT="Z" Q2
.. W !?5,"Bill # ",$P(^PRCA(430,BILL,0),"^") S X=$G(^PRCA(430,BILL,7)) W ?25,"Amt: ",$J($P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5),7,2)
.. F X=0:0 S X=$O(^PRCA(433,"C",BILL,X)) Q:'X I ",9,29,8,10,11,"[(","_$P($G(^PRCA(433,X,1)),"^",2)_",") W ?45,$P(^PRCA(430.3,+$P(^PRCA(433,X,1),"^",2),0),"^") Q
.. W:'X ?40,"Unknown Type"
Q2 .. Q
. I DEBT="Z" G Q1
. I PRI S DEBT=DEBT_.1 G Q1
. D:$Y+5>IOS HDR G:DEBT="Z" Q1
. W !?5,"Trans #: ",TRAN,?20,"Date: ",$$SLH^RCFN01(DATE) S X=$G(^PRCA(433,TRAN,3)) W ?40,"Amt: ",$J($P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5),7,2)
. W ?60,$P(^PRCA(430.3,+$P(^PRCA(433,TRAN,1),"^",2),0),"^")
Q1 . Q
Q
HDR ;Print Header of report
I $E(IOST)="C" R !!,"Press return to continue: ",X:DTIME S:'$T DTOUT=1 I X["^"!$D(DTOUT) S DEBT="Z" G Q3
W @IOF
HDR1 ;
S PAGE=PAGE+1
W !!,"Payments Received for Patient Accounts with Written-off Bills",?IOM-($L(PAGE)+7),"Page: ",PAGE
W !,"From ",$$SLH^RCFN01(BEG)," thru ",$$SLH^RCFN01(END) S X="Date: "_$$SLH^RCFN01(DT) W ?IOM-$L(X)-1,X,!
S X="",$P(X,"-",80)="" W X,!
Q3 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAWOF 2577 printed Oct 16, 2024@17:42:57 Page 2
PRCAWOF ;WASH-ISC@ALTOONA,PA/RGY-AR WRITE-OFF REPORT ;8/23/95 9:00 AM
V ;;4.5;Accounts Receivable;**20*,104*;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW BEG,DIR,DIROUT,DIRUT,DTOUT,DUOUT,END,IOS,X,Y,%DT,%ZIS,ZTSK
BEG ;
+1 WRITE !
DO NOW^%DTC
SET %DT(0)=-%
SET %DT="AEXP"
SET %DT("A")="Starting Date: "
DO ^%DT
if Y<0
GOTO Q
SET BEG=Y
+2 SET %DT="AEX"
SET %DT("A")=" Ending Date: "
DO ^%DT
if Y<0
GOTO Q
SET END=Y
+3 IF BEG>END
WRITE !!,*7,"*** Beginning date is Greater than or equal to Ending date ***",!
GOTO BEG
+4 SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO Q
+5 IF $DATA(IO("Q"))
SET ZTRTN="DQ^PRCAWOF"
SET ZTSAVE("BEG")=""
SET ZTSAVE("END")=""
SET ZTDESC="Write-Off Report"
DO ^%ZTLOAD
GOTO Q
+6 USE IO
DO DQ
Q DO ^%ZISC
QUIT
DQ ;
+1 NEW DATE,DEBT,BILL,PAGE,PRI
+2 SET (DEBT,PAGE)=0
+3 if $EXTRACT(IOST)="C"
WRITE @IOF
DO HDR1
+4 FOR
SET DEBT=$ORDER(^PRCA(433,"ATD",DEBT))
if 'DEBT
QUIT
SET PRI=1
FOR DATE=BEG-.0001:0
SET DATE=$ORDER(^PRCA(433,"ATD",DEBT,DATE))
if DATE>(END+.9999)!'DATE
QUIT
FOR TRAN=0:0
SET TRAN=$ORDER(^PRCA(433,"ATD",DEBT,DATE,TRAN))
if 'TRAN
QUIT
Begin DoDot:1
+5 IF $GET(^RCD(340,+DEBT,0))'["DPT"
QUIT
+6 IF ","_$ORDER(^PRCA(430.3,"AC",2,0))_","_$ORDER(^PRCA(430.3,"AC",20,0))_","'[(","_$PIECE($GET(^PRCA(433,TRAN,1)),"^",2)_",")
QUIT
+7 IF PRI
FOR BILL=0:0
SET BILL=$ORDER(^PRCA(430,"C",DEBT,BILL))
if 'BILL
QUIT
Begin DoDot:2
+8 IF $PIECE($GET(^PRCA(430,BILL,0)),"^",8)'=$ORDER(^PRCA(430.3,"AC",109,0))
GOTO Q2
+9 IF PRI
if $Y+5>IOSL
DO HDR
if DEBT="Z"
GOTO Q2
WRITE !,$PIECE($GET(^DPT(+$PIECE(^RCD(340,DEBT,0),"^"),0)),"^")
SET X=$PIECE(^(0),"^",9)
WRITE " (",$EXTRACT(X,1,3),"-",$EXTRACT(X,4,5),"-",$EXTRACT(X,6,9),")"
SET PRI=0
+10 if $Y+5>IOSL
DO HDR
if DEBT="Z"
GOTO Q2
+11 WRITE !?5,"Bill # ",$PIECE(^PRCA(430,BILL,0),"^")
SET X=$GET(^PRCA(430,BILL,7))
WRITE ?25,"Amt: ",$JUSTIFY($PIECE(X,"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)+$PIECE(X,"^",4)+$PIECE(X,"^",5),7,2)
+12 FOR X=0:0
SET X=$ORDER(^PRCA(433,"C",BILL,X))
if 'X
QUIT
IF ",9,29,8,10,11,"[(","_$PIECE($GET(^PRCA(433,X,1)),"^",2)_",")
WRITE ?45,$PIECE(^PRCA(430.3,+$PIECE(^PRCA(433,X,1),"^",2),0),"^")
QUIT
+13 if 'X
WRITE ?40,"Unknown Type"
Q2 QUIT
End DoDot:2
if DEBT="Z"
QUIT
+1 IF DEBT="Z"
GOTO Q1
+2 IF PRI
SET DEBT=DEBT_.1
GOTO Q1
+3 if $Y+5>IOS
DO HDR
if DEBT="Z"
GOTO Q1
+4 WRITE !?5,"Trans #: ",TRAN,?20,"Date: ",$$SLH^RCFN01(DATE)
SET X=$GET(^PRCA(433,TRAN,3))
WRITE ?40,"Amt: ",$JUSTIFY($PIECE(X,"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)+$PIECE(X,"^",4)+$PIECE(X,"^",5),7,2)
+5 WRITE ?60,$PIECE(^PRCA(430.3,+$PIECE(^PRCA(433,TRAN,1),"^",2),0),"^")
Q1 QUIT
End DoDot:1
+1 QUIT
HDR ;Print Header of report
+1 IF $EXTRACT(IOST)="C"
READ !!,"Press return to continue: ",X:DTIME
if '$TEST
SET DTOUT=1
IF X["^"!$DATA(DTOUT)
SET DEBT="Z"
GOTO Q3
+2 WRITE @IOF
HDR1 ;
+1 SET PAGE=PAGE+1
+2 Press return to continue: WRITE !!,"Payments Received for Patient Accounts with Written-off Bills",?IOM-($LENGTH(PAGE)+7),"Page: ",PAGE
+3 WRITE !,"From ",$$SLH^RCFN01(BEG)," thru ",$$SLH^RCFN01(END)
SET X="Date: "_$$SLH^RCFN01(DT)
WRITE ?IOM-$LENGTH(X)-1,X,!
+4 SET X=""
SET $PIECE(X,"-",80)=""
WRITE X,!
Q3 QUIT
