- 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 Mar 13, 2025@20:45:53 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
