source: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAXP.m@ 628

PRCAXP ;WASH-ISC@ALTOONA,PA/TJK-PRINT RX-COPAY EXEMPTION REPORT ;10/23/93  10:01 AM
V ;;4.5;Accounts Receivable;;Mar 20, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 NEW BEG,END,%DT,%ZIS,IOP,POP,Y,%
BEG W ! D NOW^%DTC S %DT(0)=-%,%DT="AEXP",%DT("A")="Start Date: " D ^%DT G:Y<0 Q S BEG=Y
 S %DT="AEX",%DT("A")="     End Date: ",%DT("B")="T" D ^%DT G:Y<0 Q S END=Y
 W ! K IO("Q") S %ZIS="MQ" D ^%ZIS G:POP Q
 I $D(IO("Q")) S ZTRTN="DQ^PRCAXP",ZTSAVE("BEG")="",ZTSAVE("END")="" D ^%ZTLOAD G Q
 U IO
DQ ;ENTRY POINT FROM TASK MANAGER FOR PRINTING REPORT
 NEW Y,TODAY,PG,I,PRCA,PRCAHDR,BEGPR,ENDPR,TRDATE,TRNO,T0,T1,BILL,TRAMT,OUT,PTNM,DFN,CONTINUE,ID,REC,TTYPE,VA,PTOT,PGTOT,TOT
COMPUTE ;SETS TEMPORARY GLOBAL FOR PRINTING
 K ^TMP($J) S TRDATE=BEG-1,(TOT("D"),TOT("E"),TOT("I"))=0,U="^"
 F  S TRDATE=$O(^PRCA(433,"ACE",TRDATE)) G PRINT:'TRDATE!($P(TRDATE,".")>END) S TRNO=0 D
    .F  S TRNO=$O(^PRCA(433,"ACE",TRDATE,TRNO)) Q:'TRNO  D
      ..S T0=$G(^PRCA(433,TRNO,0)),T1=$G(^(1)) Q:T0=""
      ..S BILL=$P(T0,U,2),TRAMT=$P(T1,U,5),TTYPE=$S($P(T1,U,2)=35:"D",$P(T1,U,2)=1:"I",1:"E")
      ..S DFN=$P(^PRCA(430,BILL,0),U,9),BILL=$P(^(0),U)
      ..S DFN=$P(^RCD(340,+DFN,0),U) Q:'DFN!(DFN'["DPT(")  S DFN=+DFN
      ..D DEM^VADPT S PTNM=VADM(1),ID=VA("PID") S DTH=$S(+VADM(6):"*",1:"") D KVAR^VADPT
      ..S ^TMP($J,PTNM,DFN,BILL,TRNO)=TRAMT_U_ID_U_TTYPE_U_DTH K DTH
PRINT ;PRINT REPORT
 S Y=BEG X ^DD("DD") S BEGPR=Y
 S Y=END X ^DD("DD") S ENDPR=Y
 S Y=DT X ^DD("DD") S TODAY=Y,PG=0 D HEAD
 I '$D(^TMP($J)) W !!,"NO EXEMPTIONS FOR THIS TIME PERIOD" G Q
 S PTNM="" F  S PTNM=$O(^TMP($J,PTNM)) Q:PTNM=""!($D(OUT))  D
    .S DFN=0 F  S DFN=$O(^TMP($J,PTNM,DFN)) Q:'DFN!($D(OUT))  S CONTINUE="",PTOT=0 D  I PTOT W !,?66,"-------------",!,?66,$J(+PTOT,13,2),!
       ..S BILL="" F  S BILL=$O(^TMP($J,PTNM,DFN,BILL)) Q:BILL=""!($D(OUT))  D
          ...S TRNO=0 F  S TRNO=$O(^TMP($J,PTNM,DFN,BILL,TRNO)) Q:TRNO=""!($D(OUT))  D
 ....S REC=^TMP($J,PTNM,DFN,BILL,TRNO) W ! W:$D(CONTINUE) $P(^(TRNO),"^",4),$E(PTNM,1,25)," ",?27,$P(REC,U,2) W ?43,BILL,?55,TRNO,?63,$P(REC,U,3),?66,$J(+REC,13,2)
 ....S PTOT=PTOT+REC,PGTOT=+$G(PGTOT)+REC,TOT($S($P(REC,U,3)]"":$P(REC,U,3),1:"UNK"))=$G(TOT($S($P(REC,U,3)]"":$P(REC,U,3),1:"UNK")))+REC
 ....K CONTINUE D HEAD:($Y+4)>IOSL
 G:$D(OUT) Q
 W !,"* -indicates patient is deceased"
 D HEAD:($Y+7)>IOSL
 W !!,"EXEMPTION TYPES AND TOTALS"
 W !!,"D=DECREASE ADJUSTMENT ",?35,$J(TOT("D"),13,2),!,"E=INTEREST/ADMIN EXEMPTION ",?35,$J(TOT("E"),13,2),!,"I=INCREASE ADJUSTMENT FOR REFUND ",?35,$J(TOT("I"),13,2)
 I $D(TOT("UNK")) W !,"UNK=EXEMPTION TYPE UNKNOWN",?35,$J(TOT("UNK"),13,2)
 W !,?35,"-------------",!,?35,$J(PGTOT,13,2)
Q K BEG,END,IO("Q") K ^TMP($J) D ^%ZISC Q
HEAD ;PRINTS HEADING
 I PG,$E(IOST,1,2)["C-" D SCR Q:$D(OUT)
 W @IOF S PG=PG+1
 W !!,"Pg. "_PG,?79-$L(TODAY),TODAY
 S PRCAHDR="MEDICATION CO-PAY EXEMPTION REPORT",PRCA="",$P(PRCA,"*",(77-$L(PRCAHDR))\2)="*",PRCAHDR=PRCA_" "_PRCAHDR_" "_PRCA
 W !,PRCAHDR,!,?28,BEGPR,"-",ENDPR
 W !,?42,"BILL",?54,"TRAN.",?62,"EXEMPTION"
 W !,"PATIENT",?26,"ID",?42,"NUMBER",?54,"NUMBER",?62,"TYPE",?73,"AMOUNT"
 S PRCA="",$P(PRCA,"-",80)="" W !,PRCA
 S CONTINUE=""
 Q
SCR ;
 Q:$E(IOST,1,2)'["C-"
 N DIR,YY,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
 F YY=$Y:1:(IOSL-2) W !
 S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DTOUT)) S OUT=1
 Q