source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVDIAG.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1WVDIAG ;HCIOFO/FT,JR IHS/ANMC/MWR - PRINTOUT OF WV DIAGNOSIS FILE; ;8/10/98 14:56
2 ;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
4 ;; CALLED BY OPTION: "WV PRINT RES/DIAG FILE" TO PRINT THE
5 ;; RESULTS/DIAGNOSIS TABLE FILE.
6 ;
7 D SETUP
8 D TITLE^WVUTL5("LISTING OF RESULTS/DIAGNOSIS FILE")
9 D DEVICE I WVPOP D EXIT Q
10 D SORT
11 D DISPLAY
12 ;
13EXIT ;EP
14 D KILLALL^WVUTL8
15 Q
16 ;
17SETUP ;EP
18 D SETVARS^WVUTL5 S WVPOP=0
19 S WVLINE=$$REPEAT^XLFSTR("-",80)
20 Q
21 ;
22DEVICE ;EP
23 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
24 S ZTRTN="DEQUEUE^WVDIAG"
25 F WVSV="WVLINE","WVTITLE" D
26 .I $D(WVSV) S ZTSAVE(WVSV)=""
27 D ZIS^WVUTL2(.WVPOP,1)
28 Q
29 ;
30SORT ;EP
31 ;---> SORT BY RESULT/DIAGNOSIS. STORED IN ^TMP("WV",$J,1
32 N N,X,Y K ^TMP("WV",$J)
33 S N=0
34 F S N=$O(^WV(790.31,"B",N)) Q:N="" D
35 .S M=$O(^WV(790.31,"B",N,0))
36 .S Y=^WV(790.31,M,0),WVDIAG=N
37 .F I=3:1:19 I $P(Y,U,I) D
38 ..S WVPN=$E($P(^WV(790.2,$P(Y,U,I),0),U),1,30)
39 ..S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
40 ..S WVPRIO=$P(Y,U,2)
41 ..S X=WVDIAG_U_WVPRIO_U_WVNORM_U_WVPN
42 ..S ^TMP("WV",$J,1,WVDIAG,WVPN,1)=X
43 .I $P(Y,U,20) D
44 ..S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
45 ..S WVPRIO=$P(Y,U,2),WVPN="ALL PROCEDURES"
46 ..S X=WVDIAG_U_WVPRIO_U_WVNORM_U_WVPN
47 ..S ^TMP("WV",$J,1,WVDIAG,WVPN,1)=X
48 ;
49 ;---> SORT BY PROCEDURE TYPE. STORED IN ^TMP("WV",$J,2
50 S N=0
51 F S N=$O(^WV(790.31,"P",N)) Q:N="" D
52 .S M=0
53 .F S M=$O(^WV(790.31,"P",N,M)) Q:M="" D
54 ..S Y=^WV(790.31,M,0)
55 ..S WVPN=$P(^WV(790.2,N,0),U),WVDIAG=$P(Y,U)
56 ..S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
57 ..S WVPRIO=$P(Y,U,2)
58 ..S X=WVPN_U_WVDIAG_U_WVPRIO_U_WVNORM
59 ..S ^TMP("WV",$J,2,WVPN,WVPRIO,WVDIAG)=X
60 ;
61 ;---> ASSOCIATED WITH ALL PROCEDURES
62 S N=0
63 F S N=$O(^WV(790.31,N)) Q:'N D
64 .S Y=^WV(790.31,N,0)
65 .Q:'$P(Y,U,20)
66 .S WVDIAG=$P(Y,U),WVPRIO=$P(Y,U,2)
67 .S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
68 .S M=0
69 .F S M=$O(^WV(790.2,M)) Q:'M D
70 ..S WVPN=$P(^WV(790.2,M,0),U)
71 ..Q:$P(^WV(790.2,M,0),U,12)
72 ..S X=WVPN_U_WVDIAG_U_WVPRIO_U_WVNORM
73 ..S ^TMP("WV",$J,2,WVPN,WVPRIO,WVDIAG)=X
74 ;
75 ;---> SORT BY PRIORITY. STORED IN ^TMP("WV",$J,3
76 S N=0
77 F S N=$O(^WV(790.31,"B",N)) Q:N="" D
78 .S M=$O(^WV(790.31,"B",N,0))
79 .S Y=^WV(790.31,M,0),WVDIAG=N,WVPRIO=$P(Y,U,2)
80 .S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
81 .S X=WVDIAG_U_WVPRIO_U_WVNORM
82 .S ^TMP("WV",$J,3,WVPRIO,WVDIAG,1)=X
83 ;
84 ;---> COPY TO TMP IN A SINGLE SUBSCRIPT.
85 F WVS=1,2,3 S WVSS=WVS_WVS D COPYGBL
86 Q
87 ;
88DISPLAY ;EP
89 U IO
90 S WVTITLE1="* WOMEN'S HEALTH: LISTING OF RESULTS/DIAGNOSIS FILE *"
91 D CENTERT^WVUTL5(.WVTITLE1)
92 S WVCRT=$S($E(IOST)="C":1,1:0),(WVPAGE,WVPOP)=0
93 F WVI=22,33,11 D @("DISPLY"_WVI) Q:WVPOP
94 D ^%ZISC
95 Q
96 ;
97DISPLY11 ;EP
98 ;---> LIST BY RESULT/DIAGNOSIS
99 ;Q
100 S WVTITLE2=" * BY DIAGNOSIS *" D CENTERT^WVUTL5(.WVTITLE2)
101 S WVSUB="W !?3,""RESULT/DIAGNOSIS"",?31,""PRIORITY"",?42,""NORMAL"","
102 S WVSUB=WVSUB_"?50,""ASSOCIATED PROCEDURES"""
103 N Z S (WVPOP,N,Z)=0
104 W:WVCRT @IOF D HEADER
105 F S N=$O(^TMP("WV",$J,WVI,N)) Q:'N!(WVPOP) D
106 .I $Y+8>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER
107 .S Y=^TMP("WV",$J,WVI,N) W !
108 .I $P(Y,U)'=Z W !?3,$P(Y,U),?37,$J($P(Y,U,2),2),?42,$P(Y,U,3)
109 .W ?50,$P(Y,U,4)
110 .S Z=$P(Y,U)
111 I WVCRT&('WVPOP) W !! D DIRZ^WVUTL3
112 Q
113 ;
114DISPLY22 ;EP
115 ;---> LIST BY RESULT/DIAGNOSIS
116 S WVTITLE2=" * BY PROCEDURE *" D CENTERT^WVUTL5(.WVTITLE2)
117 S WVSUB="W !?3,""PROCEDURE"",?35,""RESULT/DIAGNOSIS"""
118 S WVSUB=WVSUB_",?62,""PRIORITY"",?72,""NORMAL"""
119 N Z S (WVPOP,N,Z)=0
120 W:WVCRT @IOF D HEADER
121 F S N=$O(^TMP("WV",$J,WVI,N)) Q:'N!(WVPOP) D
122 .I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER
123 .S Y=^TMP("WV",$J,WVI,N) W !
124 .I $P(Y,U)'=Z W !?3,$P(Y,U)
125 .W ?35,$P(Y,U,2),?68,$J($P(Y,U,3),2),?72,$P(Y,U,4)
126 .S Z=$P(Y,U)
127 I WVCRT&('WVPOP) W !! D DIRZ^WVUTL3
128 Q
129 ;
130DISPLY33 ;EP
131 ;---> LIST BY RESULT/DIAGNOSIS
132 S WVTITLE2=" * BY PRIORITY *" D CENTERT^WVUTL5(.WVTITLE2)
133 S WVSUB="W !?3,""RESULT/DIAGNOSIS"",?32,""PRIORITY"",?44,""NORMAL"""
134 N Z S (WVPOP,N,Z)=0
135 W:WVCRT @IOF D HEADER
136 F S N=$O(^TMP("WV",$J,WVI,N)) Q:'N!(WVPOP) D
137 .I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER
138 .S Y=^TMP("WV",$J,WVI,N)
139 .W !?3,$P(Y,U),?37,$J($P(Y,U,2),2),?44,$P(Y,U,3)
140 .S Z=$P(Y,U)
141 I WVCRT&('WVPOP) W !! D DIRZ^WVUTL3
142 Q
143 ;
144 ;
145HEADER ;EP
146 W:WVPAGE @IOF S WVPAGE=WVPAGE+1,Z=0
147 W WVTITLE1,?70,"PAGE ",WVPAGE,!,WVTITLE2
148 W !,$$RUNDT^WVUTL1A("C")
149 W !,WVLINE X WVSUB W !,WVLINE
150 Q
151 ;
152COPYGBL ;EP
153 ;---> COPY ^TMP("WV",$J,WVS TO ^TMP("WV",$J,WVSS TO MAKE IT FLAT.
154 N I,M,N,P,Q
155 S N=0,I=0
156 F S N=$O(^TMP("WV",$J,WVS,N)) Q:N="" D
157 .S M=0
158 .F S M=$O(^TMP("WV",$J,WVS,N,M)) Q:M="" D
159 ..S P=0
160 ..F S P=$O(^TMP("WV",$J,WVS,N,M,P)) Q:P="" D
161 ...S I=I+1,^TMP("WV",$J,WVSS,I)=^TMP("WV",$J,WVS,N,M,P)
162 Q
163 ;
164DEQUEUE ;EP
165 ;---> CALLED BY TASKMAN
166 D SETVARS^WVUTL5,SORT,DISPLAY,EXIT
167 Q
Note: See TracBrowser for help on using the repository browser.