source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXAECQ.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1ECXAECQ ;ALB/JAP - ECQ Extract Audit Report ; 5/22/02 3:47pm
2 ;;3.0;DSS EXTRACTS;**8,33,35,43,44**;Dec 22, 1997
3 ;
4EN ;entry point for ECQ extract audit report
5 N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,ECXQV,ECXPOS,ECXYR,ECXMTH,ECXPFLG,ECXOPT,QFLG,Q2FLG
6 S (ECXERR,QFLG)=0
7 ;ecxaud=0 for 'extract' audit
8 S ECXHEAD="ECQ",ECXAUD=0
9 W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
10 ;select extract
11 D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
12 Q:ECXERR
13 ;determine if version 3 and using EC National Procedure Codes for current fiscal year
14 D FILE^DID(509850.6,,"VERSION","ARR","ERR")
15 S ECXQV=$G(ARR("VERSION"))
16 S ECXPOS=29
17 I +ECXQV=3 D
18 .S ECXYR=$E($P(ECXARRAY("START"),",",2),4,5)
19 .S ECXMTH=$E(ECXARRAY("START"),1,3)
20 .I (ECXMTH="OCT")!(ECXMTH="NOV")!(ECXMTH="DEC") S ECXYR=ECXYR+1
21 .S ECDA=0 F S ECDA=$O(^ACK(509850.8,ECDA)) Q:'ECDA!QFLG S ECDIV=0 F S ECDIV=$O(^ACK(509850.8,ECDA,2,ECDIV)) Q:'ECDIV!QFLG D
22 ..S ECCL=0 F S ECCL=$O(^ACK(509850.8,ECDA,2,ECDIV,2,"B",ECXYR,ECCL)) Q:'ECCL!QFLG D
23 ...S ECXPFLG=$P($G(^ACK(509850.8,ECDA,2,ECDIV,2,ECCL,0)),U,2)
24 ...I ECXPFLG D S QFLG=1
25 ....W !!,"Your site has division(s) which are using EC National Procedure Codes for the",!,"fiscal year covering the time period of this extract."
26 ....W !!,"You have the option to display either EC National Procedure Codes or CPT Codes",!,"for these division(s)."
27 ....F D Q:Q2FLG
28 .....S Q2FLG=1
29 .....S DIR(0)="S^1:EC National Procedure Codes;2:CPT Codes",DIR("A")="Selection",DIR("B")=1 D ^DIR K DIR S ECXOPT=Y
30 .....I X["^" W !!,"This is a required response" S Q2FLG=0
31 ....I ECXOPT=1 S ECXPOS=12
32 ;currently, quasar does not accommodate multi-divisional sites
33 S ECXALL=0
34 D ECQ^ECXDVSN1(.ECXDIV,ECXALL,.ECXERR)
35 I ECXERR=1 D Q
36 .W !!,?5,"Try again later... exiting.",!
37 .D AUDIT^ECXKILL
38 ;determine output device and queue if requested
39 W !
40 S ECXPGM="PROCESS^ECXAECQ",ECXDESC="ECQ Extract Audit Report"
41 S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="",ECXSAVE("ECXPOS")=""
42 W !
43 D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
44 I ECXSAVE("POP")=1 D Q
45 .W !!,?5,"Try again later... exiting.",!
46 .D AUDIT^ECXKILL
47 I ECXSAVE("ZTSK")=0 D
48 .K ECXSAVE,ECXPGM,ECXDESC
49 .D PROCESS^ECXAECQ
50 I IO'=IO(0) D ^%ZISC
51 D HOME^%ZIS
52 D AUDIT^ECXKILL
53 Q
54 ;
55PROCESS ;process data in file #727.825
56 N X,Y,W,ADIV,DATA,DATE,DIV,DIVACK,IEN,LOC,ECNIEN
57 N UNIT,UNITN,VOL,PROC,PROCN,SDIV,QQFLG,CNT
58 K ^TMP($J,"ECXAUD"),^TMP($J,"ECXPROC")
59 S (CNT,QQFLG)=0,ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
60 S X=ECXARRAY("START") D ^%DT S ECXSTART=Y,X=ECXARRAY("END")
61 D ^%DT S ECXEND=Y
62 ;get run date in external format
63 D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
64 ;get the dss unit links for this division/site
65 S DIV=0
66 F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D
67 .S DIVACK=$P(ECXDIV(DIV),U,1),ECXLINK(DIV)=^ACK(509850.8,DIVACK,"DSS")
68 ;get extract records in date range
69 S IEN=""
70 F S IEN=$O(^ECX(727.825,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG
71 .S DATA=^ECX(727.825,IEN,0),DIV=$P(DATA,U,4),DATE=$P(DATA,U,9)
72 .S ADIV=$P(^ECX(727.825,IEN,1),U,11) S:ADIV="" ADIV="UNK"
73 .I +ADIV S X=^DG(40.8,ADIV,0),ADIV=$P(X,U)_" ("_$P(X,U,2)_")"
74 .;convert free text date to fm internal format date
75 .S $E(DATE,1,2)=$E(DATE,1,2)-17
76 .Q:$L(DATE)<7 Q:(DATE<ECXSTART) Q:(DATE>ECXEND)
77 .;if location is among those selected, then tally event capture data
78 .I $D(ECXDIV(DIV)) D Q:QQFLG
79 ..;any quasar site that doesn't have links to dss is identified by "xx"
80 ..S UNIT=$P(DATA,U,10)
81 ..S LOC=$S(UNIT=$P(ECXLINK(DIV),U,1):"A",UNIT=$P(ECXLINK(DIV),U,2):"S",1:"XX")
82 ..;any invalid cpt code is identified as "xxxxx"
83 ..S PROC=$E($P(DATA,U,ECXPOS),1,5),VOL=$P(DATA,U,13),PROCN=""
84 ..I ECXPOS=12 D
85 ...S ECNIEN=0,ECNIEN=$O(^EC(725,"D",PROC,ECNIEN)) Q:'ECNIEN
86 ...S PROCN=$P($G(^EC(725,+ECNIEN,0)),U)
87 ..I PROCN="" D
88 ...S ECNIEN=0,ECNIEN=$O(^ICPT("B",PROC,ECNIEN)) Q:'ECNIEN
89 ...S PROCN=$P($G(^ICPT(ECNIEN,0)),U,2)
90 ..S PROC="A"_PROC S:VOL="" VOL=1
91 ..S:PROCN="" PROCN="Unknown"
92 ..I '$D(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)) S ^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)=0_U_PROCN
93 ..S $P(^(PROC),U,1)=$P(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC),U,1)+VOL,CNT=CNT+1
94 ..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ
95 ;print the report
96 D PRINT
97 D AUDIT^ECXKILL
98 Q
99 ;
100PRINT ;print quasar data by site and dss unit order
101 N JJ,SS,LN,P,LOC,UNITN,PG,QFLG,GTOT,STOT,TOT,PROC,PROCN
102 N DIR,DIRUT,DIV,DIVNM,DTOUT,DUOUT
103 U IO
104 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
105 S (QFLG,PG)=0,$P(LN,"-",80)="",DIV=""
106 F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D Q:QFLG
107 .S DIVNM=$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"
108 .D HEADER Q:QFLG
109 .S GTOT=0,STOT("A")=0,STOT("S")=0,STOT("XX")=0
110 .I '$D(^TMP($J,"ECXAUD",DIV)) D Q
111 ..W !!,?5,"No data available for this QUASAR site.",!!
112 .I $D(^TMP($J,"ECXAUD",DIV)) S ADIV="" D
113 ..F S ADIV=$O(^TMP($J,"ECXAUD",DIV,ADIV)) Q:ADIV="" S LOC="" D Q:QFLG
114 ...F S LOC=$O(^TMP($J,"ECXAUD",DIV,ADIV,LOC)) Q:LOC="" D Q:QFLG
115 ....;write the unit name
116 ....S UNITN=$S(LOC="A":"Audiology",LOC="S":"Speech Pathology",1:"Unknown"),PROC=""
117 ....D:($Y+2>IOSL) HEADER Q:QFLG W !,"Division: ("_ADIV_")",!?20,UNITN
118 ....F S PROC=$O(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)) Q:PROC="" D Q:QFLG
119 .....S TOT=+^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC),PROCN=$P(^(PROC),U,2),P=$E(PROC,2,99)
120 .....S SDIV(ADIV,LOC)=$G(SDIV(ADIV,LOC))+TOT
121 .....S STOT(LOC)=STOT(LOC)+TOT,GTOT=GTOT+TOT
122 .....D:($Y+3>IOSL) HEADER Q:QFLG W !,?25,P,?35,$E(PROCN,1,30),?68,$$RJ^XLFSTR(TOT,5," ")
123 ....;write the unit subtotal
124 ....D:($Y+4>IOSL) HEADER Q:QFLG
125 ....W !,?25,$E(LN,1,54)
126 ....W !,"Volume for "_UNITN_":",?68,$$RJ^XLFSTR(+$G(SDIV(ADIV,LOC)),5," "),!!
127 .;write the division grandtotal
128 .D:($Y+5>IOSL) HEADER Q:QFLG
129 .W !!,"Total Volume for Audiology:",?68,$$RJ^XLFSTR(STOT("A"),5," ")
130 .W !,"Total Volume for Speech Pathology:",?68,$$RJ^XLFSTR(STOT("S"),5," ")
131 .W !!,"Grand Total for Site "_DIVNM_":",?68,$$RJ^XLFSTR(GTOT,5," ")
132 ;print the audit descriptive narrative
133 I $E(IOST)'="C" D
134 .W @IOF S PG=PG+1
135 .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
136 .W !,"DSS Extract Log #: "_ECXEXT
137 .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
138 .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG
139 .W !!,LN,!!
140 .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ
141 I ($E(IOST)="C"),('QFLG) D
142 .S SS=22-$Y F JJ=1:1:SS W !
143 .S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
144 Q
145 ;
146HEADER ;header and page control
147 N JJ,SS
148 I ($E(IOST)="C"),('QFLG) D
149 .S SS=22-$Y F JJ=1:1:SS W !
150 .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
151 Q:QFLG
152 W:$Y!($E(IOST)="C") @IOF S PG=PG+1
153 W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
154 W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT")
155 W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
156 W !,"Report Run Date/Time: "_ECXRUN
157 W !,"QUASAR Site: "_$P(ECXDIV(DIV),U,2)_"("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG
158 W !!,"DSS Unit",?25,"Procedure",?68,"Volume"
159 W !,LN
160 Q
Note: See TracBrowser for help on using the repository browser.