source: FOIAVistA/trunk/r/WOMENS_HEALTH-WV/WVRPPCD1.m@ 808

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

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1WVRPPCD1 ;HCIOFO/FT,JR-REPORT: PROCEDURE STATISTICS; ;7/24/01 13:55
2 ;;1.0;WOMEN'S HEALTH;**4,12**;Sep 30, 1998
3 ;; Original routine created by IHS/ANMC/MWR
4 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
5 ;; DISPLAY CODE FOR PROCEDURE STATISTICS REPORT. CALLED BY WVRPPCD.
6 ;
7 ; This routine uses the following IAs:
8 ; <NONE>
9 ;
10DISPLAY ;EP
11 ;---> WVTITLE=TITLE AT TOP OF DISPLAY HEADER.
12 ;---> WVSUBH=CODE TO EXECUTE FOR SUBHEADER (COLUMN TITLES).
13 ;---> WVCRT=1 IF OUTPUT IS TO SCREEN (ALLOWS SELECTIONS TO EDIT).
14 ;
15 U IO
16 W:$E(IOST)="C" @IOF
17 S WVTITLE="* * * WOMEN'S HEALTH: PROCEDURE STATISTICS REPORT * * *"
18 D CENTERT^WVUTL5(.WVTITLE)
19 S WVSUBH="SUBHEAD^WVRPPCD1"
20 D TOPHEAD^WVUTL7
21 S (WVPOP,N)=0
22 ;
23DISPLAY1 ;EP
24 N WVFAC,WVSB1
25 S FE="",WVFAC=0
26 F S FE=$O(^TMP("WVAR",$J,FE)) Q:FE=""!(WVPOP)!($G(ZTSTOP)=1) S FI=0 F S FI=$O(^TMP("WVAR",$J,FE,FI)) Q:'FI!(WVPOP)!($G(ZTSTOP)=1) D
27 .I WVFAC'=FI D:WVCRT&(WVFAC) DIRZ^WVUTL3 Q:WVPOP S WVFAC=FI D HEADER3 Q:$G(ZTSTOP)=1
28 .S N=0 F S N=$O(^TMP("WVAR",$J,FE,FI,N)) Q:N=""!(WVPOP) D
29 ..I $Y+12>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D Q:$G(ZTSTOP)=1
30 ...S WVPAGE=WVPAGE+1
31 ...D HEADER3 Q:$G(ZTSTOP)=1
32 ..S Y=^TMP("WVAR",$J,FE,FI,N)
33 ..S WVARJ=$S($P(Y,U)["MAMMOGRAM":1,$P(Y,U)["ULTRASOUND":1,1:0)
34 ..S WVAGRP=$$WVAGRP($P(Y,U,16))
35 ..;---> QUIT IF DISPLAYING "ALL AGES" ONLY (NOT GROUPED BY AGE).
36 ..Q:WVAGRP=1
37 ..S WVPCD="< "_$P(Y,U)_": "_WVAGRP_" >",WVPCDL=$L(WVPCD)
38 ..S X=$E(WVLINE,1,31-(WVPCDL/2))
39 ..W !!?2,X,WVPCD,X
40 ..I WVARJ W !?68," CREDIT"
41 ..W !?28,"COUNT",?43,"VETS",?56,"NON-VETS"
42 ..I WVARJ W ?66," REG. NO CR"
43 ..W !?26,"----------",?40,"----------",?55,"----------"
44 ..I WVARJ W ?67,"----- -----"
45 ..D VERTICAL
46 ..Q
47 .Q
48 I WVPOP!($G(ZTSTOP)=1) D ^%ZISC Q
49 D FACLIST^WVRPPCD3
50 N WVNAME,WVIEN,WVCNT,WVCNT1
51 S WVNAME="",WVCNT=0
52 F S WVNAME=$O(WVSB1(WVNAME)) Q:WVNAME="" D
53 .S WVIEN=0
54 .F S WVIEN=$O(WVSB1(WVNAME,WVIEN)) Q:'WVIEN D
55 ..Q:$D(^TMP("WVAR",$J,WVNAME,WVIEN))
56 ..S WVCNT=WVCNT+1
57 ..Q
58 .Q
59 I WVCNT=0 G JUMP2
60 I '$D(^TMP("WVAR",$J)) G JUMP1
61 I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3 D Q:WVPOP
62 .D:WVPOP ^%ZISC
63 .Q
64JUMP1 ;
65 S WVNAME="",WVCNT1=0
66 F S WVNAME=$O(WVSB1(WVNAME)) Q:WVNAME=""!(WVPOP)!($G(ZTSTOP)=1) D
67 .S WVIEN=0
68 .F S WVIEN=$O(WVSB1(WVNAME,WVIEN)) Q:'WVIEN!(WVPOP)!($G(ZTSTOP)=1) D
69 ..Q:$D(^TMP("WVAR",$J,WVNAME,WVIEN))
70 ..S WVCNT1=WVCNT1+1,WVPAGE=1
71 ..D HEADER4
72 ..Q:$G(ZTSTOP)=1
73 ..Q:WVCNT=WVCNT1
74 ..I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3
75 ..Q
76 .Q
77JUMP2 ;
78 I WVPOP!($G(ZTSTOP)=1) D ^%ZISC Q
79 I $O(^TMP("WVNOHCF",$J,0))'>0 D ENDREP^WVUTL7() Q
80 I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3 D Q:WVPOP
81 .D:WVPOP ^%ZISC
82 .Q
83JUMP3 ;
84 D NOFAC^WVRPPCD3 ;records with no facility
85 D ENDREP^WVUTL7()
86 Q
87 ;
88VERTICAL ;EP
89 ;---> DISPLAY IN VERTICAL FORMAT.
90 F X=1:1:24 S:$P(Y,U,X)="" $P(Y,U,X)=0
91 F X=25:1:40 S:$P(Y,U,X)'>0 $P(Y,U,X)=""
92 D PG
93 W !?14,$S($P(Y,U)="PREGNANCY TEST":"NOT PREG",1:"NORMAL:")
94 W ?24,$J($P(Y,U,4),5),?30,"(",$J($P(Y,U,5),3),"%)"
95 W ?38,$J($P(Y,U,17),5),?44,PG(1),?47,$J($P(Y,U,4)-$P(Y,U,17),8)
96 W ?59,PG(2)
97 I WVARJ W ?64,$J($P(Y,U,25),5),?72,$J($P(Y,U,33),5)
98 W !?2,"PROCEDURES"
99 W ?14,$S($P(Y,U)="PREGNANCY TEST":"PREGNANT:",1:"ABNORMAL:")
100 W ?24,$J($P(Y,U,8),5),?30,"(",$J($P(Y,U,9),3),"%)"
101 W ?38,$J($P(Y,U,19),5),?44,PG(3),?47,$J($P(Y,U,8)-$P(Y,U,19),8)
102 W ?59,PG(4)
103 I WVARJ W ?64,$J($P(Y,U,27),5),?72,$J($P(Y,U,35),5)
104 W !?14,"NO RESULT:",?24,$J($P(Y,U,12),5),?30,"(",$J($P(Y,U,13),3),"%)"
105 W ?38,$J($P(Y,U,21),5),?44,PG(5),?47,$J($P(Y,U,12)-$P(Y,U,21),8)
106 W ?59,PG(6)
107 I WVARJ W ?64,$J($P(Y,U,29),5),?72,$J($P(Y,U,37),5)
108 W !?14,"TOTAL:",?24,$J($P(Y,U,15),5),?38,$J($P(Y,U,23),5)
109 W ?44,PG(7),?47,$J($P(Y,U,15)-$P(Y,U,23),8)
110 W ?59,PG(8)
111 I WVARJ W ?64,$J($P(Y,U,31),5),?72,$J($P(Y,U,39),5)
112 W !!?14,$S($P(Y,U)="PREGNANCY TEST":"NOT PREG:",1:"NORMAL:")
113 W ?24,$J($P(Y,U,2),5),?30,"(",$J($P(Y,U,3),3),"%)"
114 W ?38,$J($P(Y,U,18),5),?44,PG(9),?47,$J($P(Y,U,2)-$P(Y,U,18),8)
115 W ?59,PG(10)
116 I WVARJ W ?64,$J($P(Y,U,26),5),?72,$J($P(Y,U,34),5)
117 W !?2,"PATIENTS"
118 W ?14,$S($P(Y,U)="PREGNANCY TEST":"PREGNANT:",1:"ABNORMAL:")
119 W ?24,$J($P(Y,U,6),5),?30,"(",$J($P(Y,U,7),3),"%)"
120 W ?38,$J($P(Y,U,20),5),?44,PG(11),?47,$J($P(Y,U,6)-$P(Y,U,20),8)
121 W ?59,PG(12)
122 I WVARJ W ?64,$J($P(Y,U,28),5),?72,$J($P(Y,U,36),5)
123 W !?14,"NO RESULT:",?24,$J($P(Y,U,10),5),?30,"(",$J($P(Y,U,11),3),"%)"
124 W ?38,$J($P(Y,U,22),5),?44,PG(13),?47,$J($P(Y,U,10)-$P(Y,U,22),8)
125 W ?59,PG(14)
126 I WVARJ W ?64,$J($P(Y,U,30),5),?72,$J($P(Y,U,38),5)
127 W !?14,"TOTAL:",?24,$J($P(Y,U,14),5),?38,$J($P(Y,U,24),5)
128 W ?44,PG(15),?47,$J($P(Y,U,14)-$P(Y,U,24),8)
129 W ?59,PG(16)
130 I WVARJ W ?64,$J($P(Y,U,32),5),?72,$J($P(Y,U,40),5)
131 Q
132PG ;FIGURES %'S FOR VETS & NON VETS
133 F JC=1:1:25 S PG(JC)=0
134 I $P(Y,U,4)'=0 S PG(1)=100*$P(Y,U,17)/$P(Y,U,4)
135 I $P(Y,U,8)'=0 S PG(3)=100*$P(Y,U,19)/$P(Y,U,8)
136 I $P(Y,U,12)'=0 S PG(5)=100*$P(Y,U,21)/$P(Y,U,12)
137 I $P(Y,U,15)'=0 S PG(7)=100*$P(Y,U,23)/$P(Y,U,15)
138 I $P(Y,U,2)'=0 S PG(9)=100*$P(Y,U,18)/$P(Y,U,2)
139 I $P(Y,U,6)'=0 S PG(11)=100*$P(Y,U,20)/$P(Y,U,6)
140 I $P(Y,U,10)'=0 S PG(13)=100*$P(Y,U,22)/$P(Y,U,10)
141 I $P(Y,U,14)'=0 S PG(15)=100*$P(Y,U,24)/$P(Y,U,14) D T
142 S PG(2)=$S($P(Y,U,4)'=0:100-PG(1),1:0)
143 S PG(4)=$S($P(Y,U,8)'=0:100-PG(3),1:0)
144 S PG(6)=$S($P(Y,U,12)'=0:100-PG(5),1:0)
145 S PG(8)=$S($P(Y,U,15)'=0:100-PG(7),1:0)
146 S PG(10)=$S($P(Y,U,2)'=0:100-PG(9),1:0)
147 S PG(12)=$S($P(Y,U,6)'=0:100-PG(11),1:0)
148 S PG(14)=$S($P(Y,U,10)'=0:100-PG(13),1:0)
149 S PG(16)=$S($P(Y,U,14)'=0:100-PG(15),1:0)
150 ;PAD %'S WITH BLANKS
151 F JC=1:1:16 S PG(JC)=" "_PG(JC) D
152 .S PG(JC)=$E(PG(JC),$L(PG(JC))-2,$L(PG(JC)))
153 .S PG(JC)="("_PG(JC)_"%)"
154 Q
155T ;ELIMINTE DECIMAL POINT IN %
156 N S F S=1,3,5,7,9,11,13,15 D
157 .S:$E($P(PG(S),".",2))'<.5 PG(S)=PG(S)+1 S PG(S)=$P(PG(S),".")
158 Q
159 ;
160WVAGRP(AGE) ;EP
161 ;Q:AGE="ALL" "All ages"
162 Q:AGE="ALL" $S(WVAGRP'=1:"Total for selected ages",1:"All ages")
163 Q:AGE=1 1
164 N I,X,Y,Z S X=WVAGRG
165 F I=1:1:$L(X,",") S Y=$P($P(X,",",I),"-",2) Q:AGE'>Y
166 S Z=$P($P(X,",",I),"-")
167 Q:AGE<Z "Under "_Y_" yrs"
168 Q:AGE>Y "Over "_Y_" yrs"
169 Q $P(X,",",I)_" yrs"
170 ;---> PUT A FINAL CHECK IN HERE?? *COMEBACK
171 Q "Unknown age"
172 ;
173 ;
174SUBHEAD ;EP
175 ;---> SUB HEADER FOR PROCEDURE BROWSE OUTPUT.
176 W !?5,"NOTE: Patient numbers are not intended to total. "
177 W "Patients may be"
178 W !," included in more than one category.",!
179 W $$REPEAT^XLFSTR("=",80)
180 Q
181HEADER3 ;EP
182 ;---> REQUIRED VARIABLES: WVBEGDT,WVCRT,WVENDDT,WVPAGE,WVTITLE,DUZ(2)
183 ;---> OPTIONAL VARIABLE: WVSUBH (SUBHEADER).
184 N X
185 W:$Y>0 @IOF
186 W !,WVTITLE,?70,"page: ",WVPAGE
187 W !,$$RUNDT^WVUTL1A("C")
188 W !!,"Facility: ",$$INSTTX^WVUTL6($S($G(WVFAC):WVFAC,1:DUZ(2)))
189 W ?53,"From: ",$$SLDT2^WVUTL5(WVBEGDT)
190 W " to ",$$SLDT2^WVUTL5(WVENDDT)
191 W !,$$REPEAT^XLFSTR("=",80)
192 I $D(WVSUBH) D @WVSUBH
193 I $D(ZTQUEUED) D STOPCHK^WVUTL10(1) Q:$G(ZTSTOP)=1
194 Q
195HEADER4 ; Header and message for facilities without data
196 N X
197 W:$Y>0 @IOF
198 W !,WVTITLE,?70,"page: ",WVPAGE
199 W !,$$RUNDT^WVUTL1A("C")
200 W !!,"Facility: "_WVNAME
201 W ?53,"From: ",$$SLDT2^WVUTL5(WVBEGDT)
202 W " to ",$$SLDT2^WVUTL5(WVENDDT)
203 W !,$$REPEAT^XLFSTR("=",80)
204 I $D(ZTQUEUED) D STOPCHK^WVUTL10(1) Q:$G(ZTSTOP)=1
205 W !!?5,"No records match the selected criteria for this facility.",!
206 Q
Note: See TracBrowser for help on using the repository browser.