source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPSCLR.m@ 1437

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

initial load of WorldVistAEHR
File size: 6.6 KB
Line 
1XUPSCLR ;OIFO-CS/GRR/RAM/DW/PN - New Person file Cleanup Report ; 1 Jan 2004
2 ;;8.0;KERNEL;**309**; Jul 10, 1995
3 ;
4 Q
5 ;
6DETAIL ; -- detailed report
7 ;
8 N TYPE
9 ;
10 S TYPE="Detail Report of"
11 ;
12 D EN
13 ;
14 Q
15 ;
16STATS ; -- totals only
17 ;
18 N TYPE
19 ;
20 S TYPE="Statistical Report of"
21 ;
22 D EN
23 ;
24 Q
25 ;
26EN ; -- entry point
27 ;
28 N ZTDESC,ZTSAVE,ZTIO,ZTDTH,X,ZTQUEUED,ZTREQ,ZTRTN,DIR,POP,Y
29 ;
30 W !!,"This option will print "_TYPE
31 W " entries missing SEX, DOB, or SSN",!
32 W "data in the New Person file (#200)",!
33 ;
34 S DIR(0)="YA",DIR("B")="Yes",DIR("A")="Do you wish to continue? "
35 S DIR("?")="Enter 'Yes' to continue or 'No' to quit"
36 D ^DIR K DIR ;ask user if they want to continue with option
37 Q:'Y!($D(DIRUT)) ;user responded No or with '^' to exit
38 ;
39 ;initialize task variables
40 S ZTDESC="New Person file Cleanup report"
41 S ZTRTN="EN1^XUPSCLR"
42 S ZTSAVE("TYPE")=TYPE
43 ;
44 I TYPE="Detail Report of" D
45 . W !!,"The report may be lengthy. "
46 . W "It is suggested to queue the report."
47 D ZIS^XUPSUTQ ;does device selection and queueing if selected
48 Q:POP ;quit if task was queued
49 ;
50EN1 ;
51 ;
52 N ACTIVE,DIR,DIRUT,DOB,SSN,FLG,I,IEN,MISS,MISSING,NODE,Y,PHONE
53 N NAME,PERSON,POP,SEX,TOTAL,VISITOR,X,XUPSDT,XUPSL,XUPSREC
54 ;
55 D INIT
56 ;
57 S IEN=.9
58 F S IEN=$O(^VA(200,IEN)) Q:'IEN D XXX
59 ;
60 I $E(TYPE,1)="D" D ZZZ Q:FLG
61 ;
62 D TOTALS
63 ;
64 W:PERSON @IOF
65 ;
66 D ^%ZISC
67 S:$D(ZTQUEUED) ZTREQ="@"
68 ;
69 Q
70 ;
71HEAD ; write report header
72 ;
73 ; pause and wait for user reponse before displaying next screen
74 I $E(IOST,1,2)="C-",NAME'="" D Q:FLG
75 .W !
76 .S DIR(0)="E" D ^DIR S FLG='Y
77 ;
78 ;if terminal clear screen first time
79 I $E(IOST,1,2)="C-",NAME="" W @IOF
80 ;
81 ;if printer do not form feed before printing first page
82 I NAME'="" W @IOF
83 ;
84 W !,?1,"New Person file Assessment Report - "
85 W XUPSREC_" Persons",?55,XUPSDT
86 W !,?1,"Person Name",?31,"IEN",?40,"Missing",?48,"Missing"
87 W ?56,"Missing",?65,"Office Phone",!,?42,"SEX",?50,"DOB",?58,"SSN",!
88 ;
89 Q
90 ;
91TOTALS ;
92 ;if terminal pause after full screen
93 I $E(TYPE,1)="D",$E(IOST)="C" D Q:FLG
94 .S DIR(0)="E" D ^DIR
95 .S:'Y FLG=1
96 ;
97 W @IOF
98 ;W !,"NOTE: Visitor entries not included in totals other "
99 ;W "than the Visitor total!",!
100 ;
101 S XUPSL="Total Entries: " W !,?(50-$L(XUPSL)),XUPSL,$J(PERSON,6,0)
102 S XUPSL="Total Visitor Entries: "
103 W !,?(50-$L(XUPSL)),XUPSL,$J(VISITOR,6,0)
104 S XUPSL="(Visitor entries not included in the following counts)"
105 W !!,?(50-$L(XUPSL)),XUPSL
106 S XUPSL="Total Non-Visitor Entries: "
107 W !,?(50-$L(XUPSL)),XUPSL,$J(PERSON-VISITOR,6,0)
108 S XUPSL="Total Entries Missing Sex Code: "
109 W !,?(50-$L(XUPSL)),XUPSL,$J(MISSING("SEX"),6,0)
110 S XUPSL="Total Entries Missing DOB: "
111 W !,?(50-$L(XUPSL)),XUPSL,$J(MISSING("DOB"),6,0)
112 S XUPSL="Total Entries Missing SSN: "
113 W !,?(50-$L(XUPSL)),XUPSL,$J(MISSING("SSN"),6,0)
114 S XUPSL="Total Entries Missing One Data Element: "
115 W !,?(50-$L(XUPSL)),XUPSL,$J(MISS(1),6,0)
116 S XUPSL="Total Entries Missing Two Data Elements: "
117 W !,?(50-$L(XUPSL)),XUPSL,$J(MISS(2),6,0)
118 S XUPSL="Total Entries Missing Three Data Elements: "
119 W !,?(50-$L(XUPSL)),XUPSL,$J(MISS(3),6,0)
120 S XUPSL="Total Entries Missing Data: "
121 W !,?(50-$L(XUPSL)),XUPSL,$J(TOTAL("MISSING"),6,0)
122 S XUPSL="Total Active Entries: "
123 W !!,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE("TOTAL"),6,0)
124 S XUPSL="Total Active Entries Missing Data: "
125 W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE("MISSING"),6,0)
126 S XUPSL="Total Active Entries Missing Sex Code: "
127 W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE("SEX"),6,0)
128 S XUPSL="Total Active Entries Missing DOB: "
129 W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE("DOB"),6,0)
130 S XUPSL="Total Active Entries Missing SSN: "
131 W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE("SSN"),6,0)
132 S XUPSL="Total Active Entries Missing One Data Elements: "
133 W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE(1),6,0)
134 S XUPSL="Total Active entries Missing Two Data Elements: "
135 W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE(2),6,0)
136 S XUPSL="Total Active Entries Missing Three Data Elements: "
137 W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE(3),6,0)
138 ;
139 ;pause before clearing screen if terminal
140 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR
141 ;
142 Q
143 ;
144XXX ;
145 S PERSON=PERSON+1 ;count IEN
146 ;
147 ; count visitors - quit if visitor
148 I '$$ACTIVE^XUSER(IEN),$D(^VA(200,IEN,8910)) D Q
149 .S VISITOR=VISITOR+1
150 ;
151 ; count active
152 I $$ACTIVE^XUSER(IEN) D
153 .S ACTIVE("TOTAL")=ACTIVE("TOTAL")+1,XUPSREC="Active"
154 ;
155 ; not active user
156 I '$$ACTIVE^XUSER(IEN) S XUPSREC="Inactive"
157 ;
158 S (SEX,DOB,SSN)="" ;initialize missing data designator
159 S MISSING=0 ;initialize total missing for this entry
160 S NODE=$G(^VA(200,IEN,1)) ;get node where data is stored
161 ;
162 I $P(NODE,"^",2)="" D ;sex is missing
163 .S SEX="X" ;flag as missing on report
164 .S MISSING("SEX")=MISSING("SEX")+1 ;add 1 to missing sex count
165 .S MISSING=MISSING+1 ;add 1 to missing data this entry count
166 .S:$$ACTIVE^XUSER(IEN) ACTIVE("SEX")=ACTIVE("SEX")+1
167 ;
168 I $P(NODE,"^",3)="" D ;dob is missing
169 .S DOB="X" ;flag as missing on report
170 .S MISSING("DOB")=MISSING("DOB")+1 ;add 1 to missing dob count
171 .S MISSING=MISSING+1 ;add 1 to missing data this entry count
172 .S:$$ACTIVE^XUSER(IEN) ACTIVE("DOB")=ACTIVE("DOB")+1
173 ;
174 I $P(NODE,"^",9)="" D ;ssn missing
175 .S SSN="X" ;flag as missing on report
176 .S MISSING("SSN")=MISSING("SSN")+1 ;add 1 to missing ssn count
177 .S MISSING=MISSING+1 ;add 1 to missing count this entry
178 .S:$$ACTIVE^XUSER(IEN) ACTIVE("SSN")=ACTIVE("SSN")+1
179 ;
180 Q:'MISSING ;entry not missing any data, nothing to print
181 ;
182 S TOTAL("MISSING")=TOTAL("MISSING")+1
183 ;
184 I $$ACTIVE^XUSER(IEN) S ACTIVE("MISSING")=ACTIVE("MISSING")+1
185 ;
186 I $$ACTIVE^XUSER(IEN) D
187 .S ACTIVE(MISSING)=ACTIVE(MISSING)+1
188 ;
189 S MISS(MISSING)=MISS(MISSING)+1
190 ;
191 I $E(TYPE,1)="D" D
192 .N X
193 .S PHONE=$P($G(^VA(200,IEN,.13)),"^",2)
194 .S X=PHONE_"^"_SEX_"^"_DOB_"^"_SSN
195 . I $P($G(^VA(200,IEN,0)),"^",1)="" Q
196 .S ^TMP($J,XUPSREC,$P(^VA(200,IEN,0),"^",1),IEN)=X
197 ;
198 Q
199 ;
200INIT ; -- initialize
201 ;
202 K ^TMP($J)
203 ;
204 S (ACTIVE("MISSING"),ACTIVE("TOTAL"),TOTAL("MISSING"))=0
205 S (PERSON,VISITOR,FLG,ACTIVE)=0
206 ;
207 F I=1:1:3 S (MISS(I),ACTIVE(I))=0
208 F I="SEX","DOB","SSN" S (ACTIVE(I),MISSING(I))=0
209 ;
210 ;get current date/time reformat to external form for header
211 N %,%I,%H D NOW^%DTC S Y=% D DD^%DT S XUPSDT=Y
212 ;
213 Q
214 ;
215ZZZ ; -- detailed output
216 ;
217 S XUPSREC="Active" D YYY Q:FLG
218 I $E(IOST,1,2)="C-" D Q:FLG
219 .W !
220 .S DIR(0)="E" D ^DIR
221 .S:'Y FLG=1
222 I $E(IOST,1,2)'="C-" W @IOF
223 ;
224 S XUPSREC="Inactive" D YYY
225 ;
226 Q
227 ;
228YYY ;
229 S NAME=""
230 ;
231 D HEAD Q:FLG
232 ;
233 F S NAME=$O(^TMP($J,XUPSREC,NAME)) Q:NAME=""!(FLG) D
234 .S IEN=0
235 .F S IEN=$O(^TMP($J,XUPSREC,NAME,IEN)) Q:'IEN!(FLG) D
236 ..S NODE=^TMP($J,XUPSREC,NAME,IEN)
237 ..S PHONE=$P(NODE,"^",1)
238 ..S SEX=$P(NODE,"^",2)
239 ..S DOB=$P(NODE,"^",3)
240 ..S SSN=$P(NODE,"^",4)
241 ..W !,$P(^VA(200,IEN,0),"^",1)
242 ..W ?31,IEN,?43,SEX
243 ..W ?51,DOB,?59,SSN,?65,PHONE
244 ..I $Y>(IOSL-6) D HEAD
245 ;
246 Q
247 ;
Note: See TracBrowser for help on using the repository browser.