| [613] | 1 | PRCAXP ;WASH-ISC@ALTOONA,PA/TJK-PRINT RX-COPAY EXEMPTION REPORT ;10/23/93 10:01 AM
|
|---|
| 2 | V ;;4.5;Accounts Receivable;;Mar 20, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | NEW BEG,END,%DT,%ZIS,IOP,POP,Y,%
|
|---|
| 5 | BEG W ! D NOW^%DTC S %DT(0)=-%,%DT="AEXP",%DT("A")="Start Date: " D ^%DT G:Y<0 Q S BEG=Y
|
|---|
| 6 | S %DT="AEX",%DT("A")=" End Date: ",%DT("B")="T" D ^%DT G:Y<0 Q S END=Y
|
|---|
| 7 | W ! K IO("Q") S %ZIS="MQ" D ^%ZIS G:POP Q
|
|---|
| 8 | I $D(IO("Q")) S ZTRTN="DQ^PRCAXP",ZTSAVE("BEG")="",ZTSAVE("END")="" D ^%ZTLOAD G Q
|
|---|
| 9 | U IO
|
|---|
| 10 | DQ ;ENTRY POINT FROM TASK MANAGER FOR PRINTING REPORT
|
|---|
| 11 | 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
|
|---|
| 12 | COMPUTE ;SETS TEMPORARY GLOBAL FOR PRINTING
|
|---|
| 13 | K ^TMP($J) S TRDATE=BEG-1,(TOT("D"),TOT("E"),TOT("I"))=0,U="^"
|
|---|
| 14 | F S TRDATE=$O(^PRCA(433,"ACE",TRDATE)) G PRINT:'TRDATE!($P(TRDATE,".")>END) S TRNO=0 D
|
|---|
| 15 | .F S TRNO=$O(^PRCA(433,"ACE",TRDATE,TRNO)) Q:'TRNO D
|
|---|
| 16 | ..S T0=$G(^PRCA(433,TRNO,0)),T1=$G(^(1)) Q:T0=""
|
|---|
| 17 | ..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")
|
|---|
| 18 | ..S DFN=$P(^PRCA(430,BILL,0),U,9),BILL=$P(^(0),U)
|
|---|
| 19 | ..S DFN=$P(^RCD(340,+DFN,0),U) Q:'DFN!(DFN'["DPT(") S DFN=+DFN
|
|---|
| 20 | ..D DEM^VADPT S PTNM=VADM(1),ID=VA("PID") S DTH=$S(+VADM(6):"*",1:"") D KVAR^VADPT
|
|---|
| 21 | ..S ^TMP($J,PTNM,DFN,BILL,TRNO)=TRAMT_U_ID_U_TTYPE_U_DTH K DTH
|
|---|
| 22 | PRINT ;PRINT REPORT
|
|---|
| 23 | S Y=BEG X ^DD("DD") S BEGPR=Y
|
|---|
| 24 | S Y=END X ^DD("DD") S ENDPR=Y
|
|---|
| 25 | S Y=DT X ^DD("DD") S TODAY=Y,PG=0 D HEAD
|
|---|
| 26 | I '$D(^TMP($J)) W !!,"NO EXEMPTIONS FOR THIS TIME PERIOD" G Q
|
|---|
| 27 | S PTNM="" F S PTNM=$O(^TMP($J,PTNM)) Q:PTNM=""!($D(OUT)) D
|
|---|
| 28 | .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),!
|
|---|
| 29 | ..S BILL="" F S BILL=$O(^TMP($J,PTNM,DFN,BILL)) Q:BILL=""!($D(OUT)) D
|
|---|
| 30 | ...S TRNO=0 F S TRNO=$O(^TMP($J,PTNM,DFN,BILL,TRNO)) Q:TRNO=""!($D(OUT)) D
|
|---|
| 31 | ....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)
|
|---|
| 32 | ....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
|
|---|
| 33 | ....K CONTINUE D HEAD:($Y+4)>IOSL
|
|---|
| 34 | G:$D(OUT) Q
|
|---|
| 35 | W !,"* -indicates patient is deceased"
|
|---|
| 36 | D HEAD:($Y+7)>IOSL
|
|---|
| 37 | W !!,"EXEMPTION TYPES AND TOTALS"
|
|---|
| 38 | 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)
|
|---|
| 39 | I $D(TOT("UNK")) W !,"UNK=EXEMPTION TYPE UNKNOWN",?35,$J(TOT("UNK"),13,2)
|
|---|
| 40 | W !,?35,"-------------",!,?35,$J(PGTOT,13,2)
|
|---|
| 41 | Q K BEG,END,IO("Q") K ^TMP($J) D ^%ZISC Q
|
|---|
| 42 | HEAD ;PRINTS HEADING
|
|---|
| 43 | I PG,$E(IOST,1,2)["C-" D SCR Q:$D(OUT)
|
|---|
| 44 | W @IOF S PG=PG+1
|
|---|
| 45 | W !!,"Pg. "_PG,?79-$L(TODAY),TODAY
|
|---|
| 46 | S PRCAHDR="MEDICATION CO-PAY EXEMPTION REPORT",PRCA="",$P(PRCA,"*",(77-$L(PRCAHDR))\2)="*",PRCAHDR=PRCA_" "_PRCAHDR_" "_PRCA
|
|---|
| 47 | W !,PRCAHDR,!,?28,BEGPR,"-",ENDPR
|
|---|
| 48 | W !,?42,"BILL",?54,"TRAN.",?62,"EXEMPTION"
|
|---|
| 49 | W !,"PATIENT",?26,"ID",?42,"NUMBER",?54,"NUMBER",?62,"TYPE",?73,"AMOUNT"
|
|---|
| 50 | S PRCA="",$P(PRCA,"-",80)="" W !,PRCA
|
|---|
| 51 | S CONTINUE=""
|
|---|
| 52 | Q
|
|---|
| 53 | SCR ;
|
|---|
| 54 | Q:$E(IOST,1,2)'["C-"
|
|---|
| 55 | N DIR,YY,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
|
|---|
| 56 | F YY=$Y:1:(IOSL-2) W !
|
|---|
| 57 | S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DTOUT)) S OUT=1
|
|---|
| 58 | Q
|
|---|
