source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQR4.m@ 1704

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

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1ACKQR4 ;AUG/JLTP BIR/PTD-Procedure Cost Statistics ; [ 12/07/95 9:52 AM ]
2 ;;3.0;QUASAR;**8**;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4OPTN ; Introduce option.
5 W @IOF,!,"This option produces a report of all CPT-4 codes used within a selected date",!,"range and their associated costs.",!
6 ;
7 ; get Division
8 S ACKDIV=$$DIV^ACKQUTL2(3,.ACKDIV,"AI") G:+ACKDIV=0 EXIT
9 ;
10 ; get date range
11 D DTRANGE^ACKQRU G:$D(DIRUT) EXIT
12 ;
13DEV W !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
14 K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
15 I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^ACKQR4",ZTDESC="QUASAR - Cost Comparison Report",ZTSAVE("ACK*")="" D ^%ZTLOAD D HOME^%ZIS K ZTSK G EXIT
16DQ ; Entry point when queued.
17 U IO
18 D SORT,PRINT G EXIT
19SORT ;
20 N ACKTME
21 K ^TMP("ACKQR4",$J) S ACKPG=0
22 D NOW^%DTC
23 S ACKXDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKTME=$P(%,".",1)
24 F ACKD=ACKBD:0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>ACKED) S ACKV=0 F S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV D
25 .S ACKHDR5=^ACK(509850.6,ACKV,5)
26 .; get division and make sure it was selected
27 .S ACKVDIV=$P(ACKHDR5,U,1) I '$D(ACKDIV(ACKVDIV)) Q
28 .S ACKCSC=$P($G(^ACK(509850.6,ACKV,2)),U) Q:ACKCSC=""
29 .I ACKCSC'="A",ACKCSC'="AT",ACKCSC'="S",ACKCSC'="ST" Q
30 .S ACKP=0 F S ACKP=$O(^ACK(509850.6,ACKV,3,ACKP)) Q:'ACKP D
31 ..S ACKPD=^ACK(509850.6,ACKV,3,ACKP,0),ACKPP=+ACKPD
32 ..S ACKPN=$P($G(^ICPT(ACKPP,0)),U) Q:ACKPN="" S ACKPDSC=$$PROCTXT^ACKQUTL8(ACKPP,ACKTME)
33 ..S ACKPC=$P(^ACK(509850.4,ACKPP,0),U,6)
34 ..; Get the Volume of times the Procedure was administered
35 ..S ACKVOL=$P(ACKPD,U,3) I ACKVOL="" S ACKVOL=1
36 ..S ACKM=0
37 ..S:'$D(^TMP("ACKQR4",$J,0,ACKVDIV,ACKPP,ACKM)) ^(ACKM)=ACKPN_U_ACKPDSC_U_ACKPC
38 ..S ^TMP("ACKQR4",$J,1,ACKVDIV,ACKCSC,ACKPP,ACKM)=$G(^TMP("ACKQR4",$J,1,ACKVDIV,ACKCSC,ACKPP,ACKM))+ACKVOL
39 K ACKVDIV
40 Q
41PRINT ;
42 I '$D(^TMP("ACKQR4",$J,1)) D Q
43 . D DHD("")
44 . W !!,"No data found for report specifications."
45 . D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
46 ; print the report for each division
47 S ACKDIV="" K ACKDCNT S ACKDCNT=0
48 F S ACKDIV=$O(ACKDIV(ACKDIV)) Q:ACKDIV=""!($D(DIRUT)) D PRINT2 Q:$D(DIRUT)
49 I '$D(DIRUT) I ACKDCNT>0 D TOTALS
50 Q
51 ;
52PRINT2 ; print for a single division
53 I '$D(^TMP("ACKQR4",$J,1,ACKDIV)) D Q
54 . D DHD(1)
55 . W !!,"No data found for report specifications.",!!
56 . D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
57 D DHD(1)
58 ;
59 S ACKCSC="",ACKT=0
60 F S ACKCSC=$O(^TMP("ACKQR4",$J,1,ACKDIV,ACKCSC)) Q:ACKCSC=""!($D(DIRUT)) D
61 .I $Y>(IOSL-9) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD(1)
62 .S ACKCSX=$S(ACKCSC="A":"Audiology",ACKCSC="S":"Speech Pathology",ACKCSC="AT":"Audiology Telephone",ACKCSC="ST":"Speech Telephone",1:"")
63 .W !!,"STOP CODE: ",ACKCSX S ACKT(ACKCSC)=0
64 .S ACKPC=0 F S ACKPC=$O(^TMP("ACKQR4",$J,1,ACKDIV,ACKCSC,ACKPC)) Q:'ACKPC!($D(DIRUT)) S ACKM="" F S ACKM=$O(^TMP("ACKQR4",$J,1,ACKDIV,ACKCSC,ACKPC,ACKM)) Q:ACKM=""!($D(DIRUT)) S ACKD=^TMP("ACKQR4",$J,0,ACKDIV,ACKPC,ACKM) D
65 ..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD(1)
66 ..S ACKQQ=^TMP("ACKQR4",$J,1,ACKDIV,ACKCSC,ACKPC,ACKM),ACKTC=ACKQQ*$P(ACKD,U,3)
67 ..S ACKT=ACKT+ACKTC,ACKT(ACKCSC)=ACKT(ACKCSC)+ACKTC
68 ..W !,$J(ACKQQ,4),?6,$P(ACKD,U),?15,$P(ACKD,U,2),$S(ACKM]0:" "_$E(ACKM,1,29),1:"")
69 ..W ?50,$J("$"_$J($P(ACKD,U,3),0,2),8),?60,$J("$"_$J(ACKTC,0,2),10)
70 .W !!,ACKCSX," Total:",?60,$J("$"_$J(ACKT(ACKCSC),0,2),10)
71 Q:$D(DIRUT)
72 I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD(1)
73 W !!,"Grand Total: ",?60,$J("$"_$J(ACKT,0,2),10)
74 D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
75 S ACKDCNT=ACKDCNT+ACKT
76 S ACKDCNT(ACKDIV)=ACKT
77 Q
78DHD(ACKDHD) ;
79 W:($E(IOST)="C")!(ACKPG>0) @IOF
80 S ACKPG=ACKPG+1
81 W "Printed: ",ACKXDT,?(IOM-8),"Page: ",ACKPG,!
82 F X="Procedure Cost Comparison","for Date Range",ACKXBD_" to "_ACKXED W ! D CNTR^ACKQUTL(X)
83 I ACKDHD W ! D CNTR^ACKQUTL("For Division: "_$$DIVNAME(ACKDIV))
84 W !!,"QUAN",?6,"CODE",?15,"DESCRIPTION",?54,"COST",?65,"TOTAL"
85 S X="",$P(X,"-",IOM)="-" W !,X
86 Q
87 ;
88EXIT ;
89 K ACKBD,ACKCSC,ACKCSX,ACKD,ACKED,ACKM,ACKMP,ACKP,ACKPC,ACKPD,ACKPDSC,ACKPG,ACKPN,ACKPP,ACKQQ,ACKT,ACKTC,ACKV,ACKXBD,ACKXDT,ACKXED,X,Y,ZTSK,^TMP("ACKQR4",$J)
90 K ACKVOL,ACKHDR5,ACKDIV
91 W:$E(IOST)="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
92 Q
93 ;
94DIVNAME(ACKVDIV) ; get division name
95 Q $$GET1^DIQ(40.8,ACKDIV_",",.01)
96 ;
97 ;
98TOTALS ; Display Totals
99 S ACKPG=ACKPG+1 W @IOF,"Printed: ",ACKXDT,?(IOM-8),"Page: ",ACKPG,!
100 F X="Procedure Cost Comparison","for Date Range",ACKXBD_" to "_ACKXED W ! D CNTR^ACKQUTL(X)
101 W ! D CNTR^ACKQUTL("Summary") W !
102 S X="",$P(X,"-",IOM)="-" W !,X,!!
103 ;
104 S ACKDIV=""
105 F S ACKDIV=$O(ACKDCNT(ACKDIV)) Q:ACKDIV="" D
106 . W !,?8,"Total for Division: "_$$DIVNAME(ACKDIV),?57,$J("$"_$J(ACKDCNT(ACKDIV),0,2),10)
107 W !!,?8,"Grand Total for all Divisions ",?57,$J("$"_$J(ACKDCNT,0,2),10)
108 Q
Note: See TracBrowser for help on using the repository browser.