source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAXP.m@ 1765

Last change on this file since 1765 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.2 KB
Line 
1PRCAXP ;WASH-ISC@ALTOONA,PA/TJK-PRINT RX-COPAY EXEMPTION REPORT ;10/23/93 10:01 AM
2V ;;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,%
5BEG 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
10DQ ;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
12COMPUTE ;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
22PRINT ;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)
41Q K BEG,END,IO("Q") K ^TMP($J) D ^%ZISC Q
42HEAD ;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
53SCR ;
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
Note: See TracBrowser for help on using the repository browser.