source: FOIAVistA/trunk/r/QUASAR-ACKQ/ACKQWLD.m@ 1801

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

initial load of FOIAVistA 6/30/08 version
File size: 4.7 KB
Line 
1ACKQWLD ;AUG/JLTP BIR/PTD-Print A&SP Capitation Report ; [ 03/28/96 10:45 AM ]
2 ;;3.0;QUASAR;;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 four-part capitation report.",!,"It includes demographic, diagnostic, procedure, and CDR data.",!
6 D GETDT^ACKQWL G:$D(DIRUT) EXIT D INIT^ACKQWL
7DEV W !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
8 K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
9 I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^ACKQWLD",ZTDESC="QUASAR - Print A&SP Capitation Report",ZTSAVE("ACK*")="" D ^%ZTLOAD D HOME^%ZIS K ZTSK G EXIT
10DQ ;Entry point when queued.
11 U IO
12 D NOW^%DTC S ACKCDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0 K ^TMP("ACKQWLD",$J)
13 D COMPILE,PRINT
14EXIT ;ALWAYS EXIT HERE
15 K %I,ACKBFY,ACKCDT,ACKDA,ACKEM,ACKM,ACKPG,AS,CDR,CPT,DIR,DIRUT,DTOUT,DUOUT,I,ICD,LN,T,X,XAS,Y,ZIP,^TMP("ACKQWLD",$J)
16 W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
17 Q
18 ;
19COMPILE ;Compile properly sorted data in ^TMP global.
20 N AS,CPT,ICD,XAS,ZIP
21 ;For all visits.
22 S I=0 F S I=$O(^ACK(509850.7,ACKDA,3,I)) Q:'I D
23 .S X=^ACK(509850.7,ACKDA,3,I,0)
24 .S ^TMP("ACKQWLD",$J,1,$P(X,U,5),$P(X,U))=$P(X,U,2,4)
25 .Q
26 ;For ICD statistics.
27 S I=0 F S I=$O(^ACK(509850.7,ACKDA,1,I)) Q:'I D
28 .S X=^ACK(509850.7,ACKDA,1,I,0)
29 .S ^TMP("ACKQWLD",$J,2,$P(X,U,4),$P(X,U),$P(X,U,5))=$P(X,U,2,3)
30 .Q
31 ;For CPT statistics.
32 S I=0 F S I=$O(^ACK(509850.7,ACKDA,2,I)) Q:'I D
33 .S X=^ACK(509850.7,ACKDA,2,I,0)
34 .S ^TMP("ACKQWLD",$J,3,$P(X,U,4),+X,$P(X,U,5))=$P(X,U,2,3)
35 .Q
36 Q
37PRINT ;Print/display results.
38 D DHD I '$O(^TMP("ACKQWLD",$J,0)) D LINE W !!,"No data found for report specifications." Q
39 D HD1
40ZIP ;For all visits.
41 S AS=0 F S AS=$O(^TMP("ACKQWLD",$J,1,AS)) Q:'AS!($D(DIRUT)) D
42 .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD1
43 .S XAS=$S(AS=203:"Audiology",1:"Speech")
44 .W !!,XAS,":"
45 .S (ZIP,T)="" F S ZIP=$O(^TMP("ACKQWLD",$J,1,AS,ZIP)) Q:ZIP=""!($D(DIRUT)) D
46 ..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD1
47 ..S X=^TMP("ACKQWLD",$J,1,AS,ZIP)
48 ..W !,ZIP,?20,$J($P(X,U,2),5),?30,$J($P(X,U,3),5),?40,$J($P(X,U),5)
49 ..S $P(T,U)=T+X,$P(T,U,2)=$P(T,U,2)+$P(X,U,2),$P(T,U,3)=$P(T,U,3)+$P(X,U,3)
50 .Q:$D(DIRUT)
51 .S $P(LN,"-",48)="" W !,LN
52 .W !,XAS," Total: ",?20,$J($P(T,U,2),5),?30,$J($P(T,U,3),5),?40,$J(+T,5)
53 Q:$D(DIRUT)
54ICD ;For ICD statistics.
55 D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
56 S AS=0 F S AS=$O(^TMP("ACKQWLD",$J,2,AS)) Q:'AS!($D(DIRUT)) D
57 .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
58 .S XAS=$S(AS=203:"Audiology",1:"Speech")
59 .W !!,XAS,":"
60 .S ICD="" F S ICD=$O(^TMP("ACKQWLD",$J,2,AS,ICD)) Q:ICD=""!($D(DIRUT)) D
61 ..S (ZIP,X)="" F S ZIP=$O(^TMP("ACKQWLD",$J,2,AS,ICD,ZIP)) Q:ZIP=""!($D(DIRUT)) D
62 ...I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
63 ...S Y=^TMP("ACKQWLD",$J,2,AS,ICD,ZIP) F I=1,2 S $P(X,U,I)=$P(X,U,I)+$P(Y,U,I)
64 ..Q:$D(DIRUT)
65 ..W !,ICD,?20,$J($P(X,U),5),?30,$J($P(X,U,2),5)
66 .Q:$D(DIRUT)
67 Q:$D(DIRUT)
68CPT ;For CPT statistics.
69 D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD3
70 S AS=0 F S AS=$O(^TMP("ACKQWLD",$J,3,AS)) Q:'AS!($D(DIRUT)) D
71 .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD3
72 .S XAS=$S(AS=203:"Audiology",1:"Speech")
73 .W !!,XAS,":"
74 .S CPT=0 F S CPT=$O(^TMP("ACKQWLD",$J,3,AS,CPT)) Q:'CPT!($D(DIRUT)) D
75 ..S (ZIP,X)="" F S ZIP=$O(^TMP("ACKQWLD",$J,3,AS,CPT,ZIP)) Q:ZIP=""!($D(DIRUT)) D
76 ...I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD3
77 ...S Y=^TMP("ACKQWLD",$J,3,AS,CPT,ZIP) F I=1,2 S $P(X,U,I)=$P(X,U,I)+$P(Y,U,I)
78 ..Q:$D(DIRUT)
79 ..W !,CPT,?20,$J($P(X,U),5),?30,$J($P(X,U,2),5)
80 .Q:$D(DIRUT)
81 Q:$D(DIRUT)
82CDR ;For CDR information.
83 D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD4
84 S (CDR,T)=0 F S CDR=$O(^ACK(509850.7,ACKDA,4,CDR)) Q:'CDR!($D(DIRUT)) D
85 .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD4
86 .S X=^ACK(509850.7,ACKDA,4,CDR,0)
87 .S Y=$O(^ACK(509850,"B",$P(X,U),0))
88 .S Y=$P($G(^ACK(509850,+Y,0)),U,2)
89 .W !,$P(X,U),?10,Y,?60,$J($P(X,U,2),6,2)
90 .S T=T+$P(X,U,2)
91 Q:$D(DIRUT)
92 W !,"Total:",?60,$J(T,6,2),!!
93 Q
94DHD ;
95 N X
96 S ACKPG=ACKPG+1 W @IOF,"Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG,!
97 F X="Audiology & Speech Pathology","Capitation Report","for",$$XDAT^ACKQUTL(ACKM) W ! D CNTR^ACKQUTL(X)
98 W ! Q
99HD1 ;Header for all visits.
100 N X
101 W !,"ZIP CODE",?21,"VISITS",?31,"UNIQUE",?42,"C&P"
102 D LINE
103 Q
104HD2 ;Header for ICD statistics.
105 N X
106 W !,"ICD",?21,"VISITS",?31,"UNIQUE"
107 D LINE
108 Q
109HD3 ;Header for CPT statistics.
110 N X
111 W !,"CPT",?21,"VISITS",?31,"UNIQUE"
112 D LINE
113 Q
114HD4 ;Header for CDR statistics.
115 N X
116 W !,"CDR ACCOUNT",?58,"% WORKLOAD"
117 D LINE
118 Q
119LINE S X="",$P(X,"-",IOM)="-" W !,X Q
Note: See TracBrowser for help on using the repository browser.