source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUTLA.m@ 1363

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1ECXUTLA ;ALB/JAP - Utilities for Audit Reports ;Sep 25, 1997
2 ;;3.0;DSS EXTRACTS;**8,14**;Dec 22, 1997
3 ;
4AUDIT(ECXHEAD,ECXERR,ECXARRAY,ECXAUD) ;set audit report parameters
5 ; input
6 ; ECXHEAD = extract HEADER CODE (required)
7 ; (from file #727.1, field #7)
8 ; ECXERR = passed-by-reference variable (required)
9 ; ECXARRAY = passed-by-reference array (required)
10 ; ECXAUD = 0/1 (optional)
11 ; 0 --> extract audit (default)
12 ; 1 --> SAS audit
13 ; output
14 ; ECXARRAY = array of audit parameters
15 ; ECXARRAY("DEF") = ien of extract type in file #727.1
16 ; ECXARRAY("TYPE") = print name for extract; field #7 in file #727.1
17 ; ECXARRAY("EXTRACT") = ien of extract in file #727
18 ; ECXARRAY("START") = start date for extract audit
19 ; ECXARRAY("END") = end date for extract audit
20 ; ECXARRAY("ERUN") = date on which extract was generated
21 ; ECXARRAY("DIV") = ien of station if file #4
22 ; error CODE
23 ; ECXERR = 1, if input problem occurs
24 ; 0, otherwise
25 ;
26 N X,Y,N,DA,DIC,DIQ,DIR,DTOUT,DUOUT,DIRUT,ECXDA,ECXTYPE,ECXSTART,ECXEND,ECXARR
27 S ECXERR=0
28 S N=$O(^ECX(727.1,"C",ECXHEAD,"")) S:N="" ECXERR=1
29 Q:ECXERR
30 S DIC="^ECX(727.1,",DIC(0)="NZ",X=N
31 D ^DIC I Y=-1 S ECXERR=1 Q
32 S ECXTYPE=$P(Y(0),U,7)_U_+Y K X,Y,DIC
33 I $G(ECXAUD)=1,ECXHEAD'="DEN",ECXHEAD'="PRE",ECXHEAD'="RAD",ECXHEAD'="SUR" S ECXERR=1
34 Q:ECXERR
35 S DIC="^ECX(727,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=$P(ECXTYPE,U),'$D(^(""PURG""))"
36 D ^DIC
37 I Y=-1!($G(DUOUT))!($G(DTOUT)) S ECXERR=1 Q
38 S DIC="^ECX(727,",(DA,ECXDA)=+Y,DR=".01;1;2;3;4;5;15;300",DIQ="ECXARR",DIQ(0)="IE"
39 D EN^DIQ1
40 W !!,?5,"Extract: ",ECXARR(727,ECXDA,2,"E")," #",ECXDA
41 W !!,?5,"Start date: ",ECXARR(727,ECXDA,3,"E")
42 W !,?5,"End date: ",ECXARR(727,ECXDA,4,"E")
43 W !,?5,"# of Records: ",ECXARR(727,ECXDA,5,"E")
44 I ECXHEAD="PRO" W !,?5,"Station: ",ECXARR(727,ECXDA,15,"E")
45 ;if transmit date exists, then ask user if audit still needed
46 I $L(ECXARR(727,ECXDA,300,"E"))>0 D
47 .W !!,?5,"The extract which you have chosen to audit"
48 .W !,?5,"was transmitted to AAC/DSS on ",ECXARR(727,ECXDA,300,"E"),".",!
49 .S DIR(0)="Y",DIR("A")="Do you want to continue with this audit report",DIR("B")="NO" D ^DIR
50 .S:$G(DIRUT) ECXERR=1 S:Y=0 ECXERR=1
51 Q:ECXERR
52 ;setup the return array
53 S ECXARRAY("EXTRACT")=ECXARR(727,ECXDA,.01,"E"),ECXARRAY("DIV")=ECXARR(727,ECXDA,15,"I"),ECXARRAY("TYPE")=$P(ECXTYPE,U),ECXARRAY("DEF")=$P(ECXTYPE,U,2)
54 S ECXARRAY("START")=ECXARR(727,ECXDA,3,"E"),ECXARRAY("END")=ECXARR(727,ECXDA,4,"E"),ECXARRAY("ERUN")=ECXARR(727,ECXDA,1,"E")
55 ;determine date range only for extract audit reports
56 I $G(ECXAUD)=0 D
57 .S ECXSTART=ECXARRAY("START"),ECXEND=ECXARRAY("END") D RANGE^ECXUTLA(.ECXSTART,.ECXEND,.ECXERR)
58 .I ECXERR K ECXARRAY
59 .Q:ECXERR
60 .S ECXARRAY("START")=ECXSTART,ECXARRAY("END")=ECXEND
61 Q
62 ;
63RANGE(ECXSTART,ECXEND,ECXERR) ;determine date range for extract audit report
64 ; input
65 ; ECXSTART = start date of extract in file #727 (required)
66 ; passed by reference
67 ; ECXEND = end date of extract in file #727 (required)
68 ; passed by reference
69 ; ECXERR = passed by reference (required)
70 ; output
71 ; ECXSTART = user selected start date
72 ; ECXEND = user selected end date
73 ; error CODE
74 ; ECXERR = 1, if input problem occurs
75 ; 0, otherwise
76 ;
77 ;
78 ;convert dates to internal format
79 N DATEA,DATEB,X,Y,%DT,DTOUT,OUT
80 S (ECXERR,OUT)=0
81 S X=ECXSTART D ^%DT S DATEA=Y
82 S X=ECXEND D ^%DT S DATEB=Y
83 ;allow user to select start date
84 ;can't be less than ecxstart or greater than ecxend
85 W !!,?5,"You can narrow the date range, if you wish.",!
86 W !,?5,"The Start Date can't be earlier than ",ECXSTART,","
87 W !,?5,"or later than ",ECXEND,".",!
88 F Q:OUT!ECXERR D
89 .S %DT="AEX",%DT("A")="Select Start Date: ",%DT("B")=ECXSTART,%DT(0)=DATEA
90 .D ^%DT S:Y=-1 ECXERR=1 S:$G(DTOUT) ECXERR=1
91 .Q:ECXERR
92 .I Y>DATEB D Q
93 ..W !,?5,"But that's later than ",ECXEND,"...try again.",!
94 .S DATEA=Y,OUT=1
95 I ECXERR K ECXSTART,ECXEND
96 Q:ECXERR
97 S Y=DATEA D DD^%DT S ECXSTART=Y
98 ;allow user to select end date
99 ;can't be less than ecxstart or greater than ecxend
100 W !!,?5,"The End Date can't be earlier than ",ECXSTART
101 W !,?5,"(the Start Date you selected), or later than ",ECXEND,".",!
102 S OUT=0
103 F Q:OUT!ECXERR D
104 .S %DT="AEX",%DT("A")="Select End Date: ",%DT("B")=ECXEND,%DT(0)=-DATEB
105 .D ^%DT S:Y=-1 ECXERR=1 S:$G(DTOUT) ECXERR=1
106 .Q:ECXERR
107 .I Y<DATEA D Q
108 ..W !,?5,"But that's earlier than ",ECXSTART,"...try again.",!
109 .S DATEB=Y,OUT=1
110 I ECXERR K ECXSTART,ECXEND
111 Q:ECXERR
112 S Y=DATEB D DD^%DT S ECXEND=Y
113 Q
114 ;
115DEVICE(ZTRTN,ZTDESC,ZTSAVE) ;get print device and optionally task to background
116 ; input
117 ; ZTRTN = line^routine; task entry point (required)
118 ; variable for %ZTLOAD
119 ; ZTDESC = task description (required)
120 ; variable for %ZTLOAD
121 ; ZTSAVE = array; passed by reference (required)
122 ; variables for %ZTLOAD
123 ; output
124 ; ZTSAVE = returns ZTSAVE("POP"),ZTSAVE("ZTSK")
125 ;
126 N POP,ZTSK
127 S ZTSAVE("POP")=0,ZTSAVE("ZTSK")=0
128 ;return ztsave("pop")=1 and quit if required input not available
129 I '$L(ZTRTN)!('$L(ZTDESC))!('$D(ZTSAVE)) S ZTSAVE("POP")=1 Q
130 ;get print device
131 K IO("Q") S %ZIS="QM" D ^%ZIS
132 S ZTSAVE("POP")=POP
133 I POP D
134 .W !,"No device selected...exiting.",!
135 Q:POP
136 I $D(IO("Q")) D
137 .S ZTSAVE("ZTREQ")="@"
138 .D ^%ZTLOAD
139 .I $G(ZTSK)>0 D
140 ..W !,"Request queued as Task #",ZTSK,".",!
141 ..S ZTSAVE("ZTSK")=ZTSK
142 ..S ZTSAVE("POP")=0
143 .I '$G(ZTSK) D
144 ..W !,"Request to queue cancelled...exiting.",!
145 ..S ZTSAVE("ZTSK")=0
146 ..S ZTSAVE("POP")=1
147 Q
148 ;
149WARDS(ECXALL,ECXDIV) ;get wards for selected divisions
150 ; input
151 ; ECXALL = 1/0 (optional)
152 ; 1==> user selected all divisions OR
153 ; facility is non-divisional
154 ; 0==> user selected some divisions
155 ; if ECXALL not defined, then assume 1
156 ; ECXDIV = array of divisions selected (optional)
157 ; passed by reference array containing
158 ; selected divisions;
159 ; if ECXALL=1, then ECXDIV array isn't
160 ; required; information for all wards will be obtained
161 ; if ECXALL=0, then only wards for divisions in ECXDIV
162 ; output
163 ; ^TMP($J,"ECXWARD", contains ward name, division, g&l order
164 ; ^TMP($J,"ECXORDER", contains ward grouping info
165 ;
166 N IEN,WARD,ORDX,NAME,NM,ORDER,DIV,HIEN,GROUP,DATA,DEPT,NAMEDEPT
167 K ^TMP($J,"ECXWARD"),^TMP($J,"ECXORDER")
168 ;if ecxall not here, then set ecxall=1
169 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
170 S ORDX=0,NM=""
171 F S NM=$O(^DIC(42,"B",NM)) Q:NM="" S IEN=0 F S IEN=$O(^DIC(42,"B",NM,IEN)) Q:IEN="" D
172 .S DIV=+$P(^DIC(42,IEN,0),U,11) Q:DIV=0
173 .I ECXALL=0,'$D(ECXDIV(DIV)) Q
174 .S (NAME,ORDER,DEPT)="",NAME=$P(^DIC(42,IEN,0),U,1),ORDER=+$P($G(^DIC(42,IEN,"ORDER")),U,1),DEPT=$P($G(^ECX(727.4,IEN,0)),U,2)
175 .;'unordered' ward is probably inactive, but get basic data anyway
176 .I ORDER=0 S ORDX=ORDX+1,ORDER="99999"_ORDX,ORDER=+ORDER
177 .;get this ward's ien in file #44; file #727.802 & #727.808 use pointers to file #44
178 .S HIEN=+$P($G(^DIC(42,IEN,44)),U,1) Q:HIEN=0
179 .;if this is last ward in group, then get the group name
180 .K GROUP I $D(^DIC(42,IEN,1,1,0)) S GROUP=$P(^DIC(42,IEN,1,1,0),U,1) I GROUP="" K GROUP
181 .S ^TMP($J,"ECXWARD",HIEN)=ORDER_U_NAME_U_DIV_U_IEN_U_DEPT
182 .I $D(GROUP) S ^TMP($J,"ECXWARD",HIEN,1)=GROUP
183 ;after all wards in file #42 are processed, arrange by g&l order
184 S HIEN=0
185 F S HIEN=$O(^TMP($J,"ECXWARD",HIEN)) Q:HIEN="" S DATA=^TMP($J,"ECXWARD",HIEN) D
186 .S ORDER=$P(DATA,U,1),NAME=$P(DATA,U,2),DIV=$P(DATA,U,3),DEPT=$P(DATA,U,5)
187 .S NAMEDEPT=NAME S:DEPT]"" NAMEDEPT=NAME_" <"_DEPT_">"
188 .S ^TMP($J,"ECXORDER",DIV,ORDER)=HIEN_U_NAMEDEPT_U
189 .I $D(^TMP($J,"ECXWARD",HIEN,1)) S GROUP=^(1),^TMP($J,"ECXORDER",DIV,ORDER,1)=1_U_GROUP_U
190 Q
191 ;
192SASHEAD(ECXFL,ECXHEAD,ECXDIV,ECXARRAY,ECXPG,ECXTAB) ;header and page control
193 ;
194 ; ECXFL = feeder location (division) (required)
195 ; ECXHEAD = extract header from file #727.1 (required)
196 ; ECXDIV = array of divisions selected (required)
197 ; ECXPG = page number (required)
198 ; ECXTAB = tab location;
199 ; allows for proper spacing in sub-header line (optional)
200 ;
201 N JJ,SS,LN
202 S $P(LN,"-",80)=""
203 I $G(ECXTAB)="" S ECXTAB=40
204 I $E(IOST)="C" D
205 .S SS=22-$Y F JJ=1:1:SS W !
206 .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
207 Q:QFLG
208 W:$Y!($E(IOST)="C") @IOF S ECXPG=ECXPG+1
209 W !,"SAS Audit Report for "_ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract"
210 W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT")
211 W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
212 W !,"Report Run Date/Time: "_ECXRUN
213 I $D(ECXDIV(ECXFL)) W !,"Division/Site: "_$P(ECXDIV(ECXFL),U,2)_" ("_ECXFL_")",?68,"Page: "_ECXPG
214 I '$D(ECXDIV(ECXFL)) W !,"Division/Site: "_"Unknown",?68,"Page: "_ECXPG
215 W !!,"Feeder Location",?ECXTAB,"Feeder Key",?68,"Quantity"
216 W !,LN,!
217 Q
Note: See TracBrowser for help on using the repository browser.