- 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 Apr 23, 2025@17:56:33 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
