PRCARFP ;WASH-ISC@ALTOONA,PA/CMS-PREPAYMENT POST REPT ;1/11/95 9:24 AM
V ;;4.5;Accounts Receivable;**90**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;Automatic payment posting from prepayment
N BEG,END,X,Y,%DT,%ZIS
ST W !! D NOW^%DTC S %DT(0)=-%,%DT="AEXP",%DT("A")="Enter Transaction START Date: " D ^%DT G:Y<0 REPQ S BEG=Y
W !! S %DT="AEX",%DT("A")="Enter Transaction END Date: " D ^%DT G:Y<0 REPQ S END=Y
I BEG>END W !!,*7," (Ending date must be greater than Start date.)" G ST
S %ZIS="MQ" D ^%ZIS G:POP REPQ
I $D(IO("Q")) S ZTRTN="DQ^PRCARFP",ZTSAVE("BEG")="",ZTSAVE("END")="",ZTDESC="Prepayment Posting Report" D ^%ZTLOAD G REPQ
U IO D DQ
REPQ W:$E(IOST,1,2)'="C-" @IOF D ^%ZISC Q
DQ ;
N BN,DAT,DFN,NOW,OUT,PAGE,PTN,TN,X,Y
D NOW^%DTC S Y=X D DD^%DT S NOW=Y
S (PAGE,OUT)=0 D HD
S DAT=0 F S DAT=$O(^PRCA(433,"AP",DAT)) Q:'DAT!(DAT>END)!(OUT) I DAT'<BEG F PTN=0:0 S PTN=$O(^PRCA(433,"AP",DAT,PTN)) Q:'PTN!(OUT) F TN=0:0 S TN=$O(^PRCA(433,"AP",DAT,PTN,TN)) Q:'TN!(OUT) D
.N VA,VADM,VAERR I ($Y+7)>IOSL D HD Q:OUT
.W !,$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3),?11,+$G(^PRCA(433,TN,0))
.S Y=$P(^PRCA(430.3,$P(^PRCA(433,TN,1),U,2),0),U,1) W ?18,$S(Y["FULL":"PAYMNT (FULL)",Y["PART":"PAYMNT (PART)",1:$E(Y,1,9))
.W ?32,"$"_$FN($P(^PRCA(433,TN,1),U,5),",",2)
.S BN=+$P(^PRCA(433,TN,0),U,2) I Y["PAY",",22,23,"'[(","_$P(^PRCA(430,BN,0),U,2)_","),$P(^(0),U,18)'="36X5287" W "*"
.I $P($G(^RCD(340,+$P(^PRCA(430,BN,0),U,9),0)),U,1)["DPT" S DFN=+$P(^(0),U,1) D DEM^VADPT
.W ?45,+$G(^PRCA(433,PTN,0)),?55,$G(VADM(1)),?69,$P(^PRCA(430,BN,0),U,1)
.I '$D(^PRCA(433,"AP",DAT,TN,PTN)) W !,?11,"**ERROR MESSAGE: Corresponding Transaction not found!" Q
.I +$P($G(^PRCA(433,TN,1)),U,5)'=+$P($G(^PRCA(433,PTN,1)),U,5) W !,?11,"**ERROR MESSAGE: Unbalanced Transaction Amounts"
.QUIT
W !!,"* - Include the payment amount on an FMS ET document",!
DQQ Q
HD ;
D:PAGE>0 SCRN G:OUT HDQ S PAGE=PAGE+1
W @IOF W !,?5,"Background Payment Posting from Prepayment Receivables",?60,"Page ",PAGE," ",NOW
W !,?10,"Reporting period: " S Y=BEG X ^DD("DD") W Y," thru " S Y=END X ^DD("DD") W Y
W !! F Y=1:1:79 W "="
W !,"Tran.",?11,"Tran.",?18,"Tran.",?32,"Tran.",?40,"Corresponding",?55,"Patient",?69,"Bill"
W !,"Date",?11,"No.",?18,"Type",?32,"Amount",?43,"Tran. No.",?55,"Name",?69,"No.",!!
HDQ Q
SCRN ;crt display exit
W !!,"* - Include the payment amount on an FMS ET document"
Q:$E(IOST,1,2)'["C-"
N DIR,DIRUT,DUOUT,DIROUT,X,Y
F Y=$Y:1:(IOSL-4) W !
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S OUT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCARFP 2598 printed Dec 13, 2024@01:41:12 Page 2
PRCARFP ;WASH-ISC@ALTOONA,PA/CMS-PREPAYMENT POST REPT ;1/11/95 9:24 AM
V ;;4.5;Accounts Receivable;**90**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;Automatic payment posting from prepayment
+3 NEW BEG,END,X,Y,%DT,%ZIS
ST WRITE !!
DO NOW^%DTC
SET %DT(0)=-%
SET %DT="AEXP"
SET %DT("A")="Enter Transaction START Date: "
DO ^%DT
if Y<0
GOTO REPQ
SET BEG=Y
+1 WRITE !!
SET %DT="AEX"
SET %DT("A")="Enter Transaction END Date: "
DO ^%DT
if Y<0
GOTO REPQ
SET END=Y
+2 IF BEG>END
WRITE !!,*7," (Ending date must be greater than Start date.)"
GOTO ST
+3 SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO REPQ
+4 IF $DATA(IO("Q"))
SET ZTRTN="DQ^PRCARFP"
SET ZTSAVE("BEG")=""
SET ZTSAVE("END")=""
SET ZTDESC="Prepayment Posting Report"
DO ^%ZTLOAD
GOTO REPQ
+5 USE IO
DO DQ
REPQ if $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
DO ^%ZISC
QUIT
DQ ;
+1 NEW BN,DAT,DFN,NOW,OUT,PAGE,PTN,TN,X,Y
+2 DO NOW^%DTC
SET Y=X
DO DD^%DT
SET NOW=Y
+3 SET (PAGE,OUT)=0
DO HD
+4 SET DAT=0
FOR
SET DAT=$ORDER(^PRCA(433,"AP",DAT))
if 'DAT!(DAT>END)!(OUT)
QUIT
IF DAT'<BEG
FOR PTN=0:0
SET PTN=$ORDER(^PRCA(433,"AP",DAT,PTN))
if 'PTN!(OUT)
QUIT
FOR TN=0:0
SET TN=$ORDER(^PRCA(433,"AP",DAT,PTN,TN))
if 'TN!(OUT)
QUIT
Begin DoDot:1
+5 NEW VA,VADM,VAERR
IF ($Y+7)>IOSL
DO HD
if OUT
QUIT
+6 WRITE !,$EXTRACT(DAT,4,5)_"/"_$EXTRACT(DAT,6,7)_"/"_$EXTRACT(DAT,2,3),?11,+$GET(^PRCA(433,TN,0))
+7 SET Y=$PIECE(^PRCA(430.3,$PIECE(^PRCA(433,TN,1),U,2),0),U,1)
WRITE ?18,$SELECT(Y["FULL":"PAYMNT (FULL)",Y["PART":"PAYMNT (PART)",1:$EXTRACT(Y,1,9))
+8 WRITE ?32,"$"_$FNUMBER($PIECE(^PRCA(433,TN,1),U,5),",",2)
+9 SET BN=+$PIECE(^PRCA(433,TN,0),U,2)
IF Y["PAY"
IF ",22,23,"'[(","_$PIECE(^PRCA(430,BN,0),U,2)_",")
IF $PIECE(^(0),U,18)'="36X5287"
WRITE "*"
+10 IF $PIECE($GET(^RCD(340,+$PIECE(^PRCA(430,BN,0),U,9),0)),U,1)["DPT"
SET DFN=+$PIECE(^(0),U,1)
DO DEM^VADPT
+11 WRITE ?45,+$GET(^PRCA(433,PTN,0)),?55,$GET(VADM(1)),?69,$PIECE(^PRCA(430,BN,0),U,1)
+12 IF '$DATA(^PRCA(433,"AP",DAT,TN,PTN))
WRITE !,?11,"**ERROR MESSAGE: Corresponding Transaction not found!"
QUIT
+13 IF +$PIECE($GET(^PRCA(433,TN,1)),U,5)'=+$PIECE($GET(^PRCA(433,PTN,1)),U,5)
WRITE !,?11,"**ERROR MESSAGE: Unbalanced Transaction Amounts"
+14 QUIT
End DoDot:1
+15 WRITE !!,"* - Include the payment amount on an FMS ET document",!
DQQ QUIT
HD ;
+1 if PAGE>0
DO SCRN
if OUT
GOTO HDQ
SET PAGE=PAGE+1
+2 WRITE @IOF
WRITE !,?5,"Background Payment Posting from Prepayment Receivables",?60,"Page ",PAGE," ",NOW
+3 WRITE !,?10,"Reporting period: "
SET Y=BEG
XECUTE ^DD("DD")
WRITE Y," thru "
SET Y=END
XECUTE ^DD("DD")
WRITE Y
+4 WRITE !!
FOR Y=1:1:79
WRITE "="
+5 WRITE !,"Tran.",?11,"Tran.",?18,"Tran.",?32,"Tran.",?40,"Corresponding",?55,"Patient",?69,"Bill"
+6 WRITE !,"Date",?11,"No.",?18,"Type",?32,"Amount",?43,"Tran. No.",?55,"Name",?69,"No.",!!
HDQ QUIT
SCRN ;crt display exit
+1 WRITE !!,"* - Include the payment amount on an FMS ET document"
+2 if $EXTRACT(IOST,1,2)'["C-"
QUIT
+3 NEW DIR,DIRUT,DUOUT,DIROUT,X,Y
+4 FOR Y=$Y:1:(IOSL-4)
WRITE !
+5 SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
SET OUT=1
+6 QUIT
