source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVRPSNP.m@ 1006

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

initial load of WorldVistAEHR

File size: 6.2 KB
Line 
1WVRPSNP ;HCIOFO/FT,JR-REPORT: SNAPSHOT OF PROGRAM ;10/14/99 14:02
2 ;;1.0;WOMEN'S HEALTH;**7,8**;Sep 30, 1998
3 ;; Original routine created by IHS/ANMC/MWR
4 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
5 ;; CALLED BY OPTION: "WV PRINT SNAPSHOT" TO DISPLAY FROM 1/1 CURRENT
6 ;; YEAR TO PRESENT #PATIENTS, #PAPS, #MAMS, #DELINQUENT NEEDS, ETC.
7 ;
8 D SETVARS^WVUTL5 S WVFAC=DUZ(2) K ^TMP("WVF",$J)
9 N A,B,C,D,E,F,G,H,I,J,K,L,M,N,P,Q,R,S,X,Y,WA,WB,WC,WE,WF,WG,WH,WX,N0
10 N WVBRTXND,WVCXTXND
11 D TITLE^WVUTL5("PROGRAM SNAPSHOT")
12 D ASKTOY G:WVPOP EXIT
13 D ASKSAVE G:WVPOP EXIT
14 D DEVICE G:WVPOP EXIT
15 D GATHER
16 D:WVA STORE
17 K WVDTIEN
18 D ^WVRPSNP1
19 ;
20EXIT ;EP
21 D KILLALL^WVUTL8
22 K ^TMP("WVF",$J)
23 Q
24 ;
25ASKTOY ;
26 S WVTOY="" S DIR("A")=" Report by (C)alendar or (F)iscal year? "
27 S DIR(0)="SAO^C:Calendar Year;F:Fiscal Year",DIR("B")="Fiscal"
28 D ^DIR
29 I "FC"'[Y S WVPOP=1 Q
30 S WVTOY=Y
31 S WVJDT=$E(DT,1,3)_"0000"
32 I WVTOY="C" Q
33 I $E(DT,4,5)<10 S WVJDT=$E(DT-10000,1,3)_"1000" Q
34 S WVJDT=$E(DT,1,3)_"1000"
35 Q
36DEVICE ;EP
37 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
38 S ZTRTN="DEQUEUE^WVRPSNP"
39 F WVSV="A","FAC","TOY","JDT" D
40 .I $D(@("WV"_WVSV)) S ZTSAVE("WV"_WVSV)=""
41 D ZIS^WVUTL2(.WVPOP,1,"HOME")
42 Q
43 ;
44ASKSAVE ;EP
45 ;---> ASK IF THIS REPORT SHOULD BE SAVED FOR LATER RETRIEVAL.
46 N DIR,DIRUT,Y
47 W !!?3,"Should today's Snapshot be stored for later retrieval and"
48 W " comparisons?"
49 S DIR(0)="Y",DIR("A")=" Enter Yes or No",DIR("B")="NO"
50 S WVA=0 D HELP1
51 D ^DIR K DIR W !
52 S:$D(DIRUT) WVPOP=1
53 S:Y WVA=1
54 Q
55 ;
56DEQUEUE ;EP
57 ;---> QUEUED REPORT
58 N A,B,C,D,E,F,G,H,J,K,L,M,N,P,Q,R,S,X,Y
59 D SETVARS^WVUTL5,GATHER,STORE,^WVRPSNP1,EXIT
60 Q
61 ;
62STORE ;EP
63 ;---> STORE REPORT DATA IN FILE #790.71.
64 Q:'WVA
65 N WVDR,DA,DIC,DIE,X,Y
66 S WVDR=".02////"_WVFAC,Y=.02
67 F WVI=A,B,C,D,E,F,G,H,S,J,K,L,P,Q,R D
68 .S Y=Y+.01,WVDR=WVDR_";"_Y_"////"_WVI
69 S Y=.5,WVJDR=".5////"_WVI(1)
70 F WVJ=2:1:30 S Y=Y+.01 S WVJDR=WVJDR_";"_Y_"////"_WVI(WVJ)
71 S WVDR=WVDR_";.18////"_WVTOY
72 N A,B,C,D,E,F,G,H,S,J,K,L,P,Q,R D
73 .S A=0,WVJNDA="" F S A=$O(^WV(790.71,"B",DT,A)) Q:A'>0 D Q:WVJNDA>0
74 ..S:$D(^WV(790.71,"T",WVTOY,A)) WVJNDA=A
75 .I WVJNDA'>0 D
76 ..K DD,DO S DIC="^WV(790.71,",DIC(0)="ML",X=DT
77 ..D FILE^DICN Q:Y<0 S WVJNDA=+Y
78 .S Y=$G(WVJNDA) Q:Y'>0
79 .D DIE^WVFMAN(790.71,WVDR,WVJNDA)
80 .D DIE^WVFMAN(790.71,WVJDR,WVJNDA)
81 Q
82 ;
83 ;
84GATHER ;EP
85 ;---> GATHER DATA
86 S (A,B,C,D,E,F,G,H,J,K,L,M,N,P,Q,R,S)=0
87 ;---> USE WVDT SO THAT THE DATE WON'T CHANGE IF RUN SPANS MIDNIGHT.
88 D SETVARS^WVUTL5 S WVDT=DT
89 S WVBRTXND=$$IEN^WVUTL9(790.51,"Not Indicated")
90 S WVCXTXND=$$IEN^WVUTL9(790.5,"Not Indicated")
91 ;
92 ;---> PATIENT DATA
93 F S N=$O(^WV(790,N)) Q:'N S Y=^WV(790,N,0) D
94 .;---> QUIT IF PATIENT IS NOT ACTIVE.
95 .Q:$P(Y,U,24)
96 .;---> QUIT IF PATIENT IS DECEASED.
97 .Q:$$DECEASED^WVUTL1($P(Y,U))
98 .;---> TOTAL ACTIVE WOMEN IN REGISTER.
99 .S A=A+1
100 .;---> WOMEN PREGNANT.
101 .I $P(Y,U,13)&($P(Y,U,14)>WVDT) S B=B+1
102 .;---> DES DAUGHTERS.
103 .S:$P(Y,U,15) C=C+1
104 .;---> WOMEN WITH CERVICAL TX NEEDS NOT SPECIFIED OR NOT DATED.
105 .; Don't count if need is "Not Indicated"
106 .I ($P(Y,U,11)'=WVCXTXND) I 5[$P(Y,U,11)!('$P(Y,U,12)) S D=D+1
107 .;---> IF DATE DUE=NULL IT WAS COUNTED LINE ABOVE, SO DON'T COUNT
108 .;---> IT IN THE LINE BELOW: +$P(Y,U,19).
109 .;---> WOMEN WITH CERVICAL TX NEEDS SPECIFIED AND PAST DUE.
110 .I ($P(Y,U,11)'=WVCXTXND) I 5'[$P(Y,U,11)&($P(Y,U,12)<WVDT)&(+$P(Y,U,12)) S E=E+1
111 .;---> WOMEN WITH BREAST TX NEEDS NOT SPECIFIED OR NOT DATED.
112 .; Don't count if need is "Not Indicated"
113 .I ($P(Y,U,18)'=WVBRTXND) I 8[$P(Y,U,18)!('$P(Y,U,19)) S F=F+1
114 .;---> WOMEN WITH BREAST TX NEEDS SPECIFIED AND PAST DUE.
115 .I ($P(Y,U,18)'=WVBRTXND) I 8'[$P(Y,U,18)&($P(Y,U,19)<WVDT)&(+$P(Y,U,19)) S G=G+1
116 ;
117 ;---> PROCEDURE DATA
118 S N=0
119 F S N=$O(^WV(790.1,"S","o",N)) Q:'N S Y=^WV(790.1,N,0) D
120 .Q:"o"'[$P(Y,U,14)
121 .Q:$P(Y,U,5)=8
122 .S H=H+1 S:$P(Y,U,13)<WVDT S=S+1
123 ;
124 ;---> TOTAL PAPS, CBES, AND MAMS FOR THIS YEAR (SINCE JAN 1, OR FISCAL).
125 S N=WVJDT,WVENDDT1=WVDT+.9999
126 F S N=$O(^WV(790.1,"D",N)) Q:'N!(N>WVENDDT1) D
127 .S M=0
128 .F S M=$O(^WV(790.1,"D",N,M)) Q:'M S Y=^WV(790.1,M,0) D
129 ..;---> BELOW IS HARD CODED FOR IENS IN ^WV(790.2, (PAP, CBE, OR MAM) AND
130 ..;---> ^WV(790.31, (ERROR/DISREGARD). COULD BE MORE ROBUST BY LOOKING
131 ..;---> AT #.10 FIELD OF ^WV(790.2 AND #.23 FIELD OF ^WV(790.31,.
132 ..Q:$P(Y,U,5)=8
133 ..I $P(Y,U,4)=1 S P=P+1 Q ;---> PAP
134 ..I $P(Y,U,4)=25!($P(Y,U,4)=26)!($P(Y,U,4)=28) S Q=Q+1 Q ;---> MAM
135 ..I $P(Y,U,4)=27 S R=R+1 ;---> CBE
136 ;
137 ;---> NOTIFICATION DATA
138 S N=0
139 F S N=$O(^WV(790.4,"AOPEN",N)) Q:'N D
140 .S M=0
141 .F S M=$O(^WV(790.4,"AOPEN",N,M)) Q:'M D
142 ..I '$D(^WV(790.4,M,0)) K ^WV(790.4,"AOPEN",N,M) Q
143 ..S Y=^WV(790.4,M,0)
144 ..S:$P(Y,U,14)="o" J=J+1
145 ..S:$P(Y,U,14)="o"&($P(Y,U,13)<WVDT) K=K+1
146 ;---> LETTERS QUEUED
147 S N=0 F S N=$O(^WV(790.4,"APRT",N)) Q:'N D
148 .S M=0 F S M=$O(^WV(790.4,"APRT",N,M)) Q:'M S L=L+1
149R ;---> TREATMENT REFUSALS
150 N WVREFPCE
151 ;piece # and its value form a link for refusal counts
152 ; (e.g., piece 1 has a value of 24). Entry #1 in File 790.2 is Pap Smear
153 ; and the # of refused Pap Smears is stored in piece 24 (of node 2)
154 ; in File 790.71.
155 S WVREFPCE="24^4^13^6^^^7^9^^^^^^^^^16^8^5^25^26^14^15^12^18^19^2^20^11^22^23^17^21^10^27^^3^1^28^29^30"
156 F WA=1:1:41 D
157 .S WB=$P(WVREFPCE,U,WA)
158 .Q:'WB
159 .S WVI(WB)=0
160 S WA=WVJDT F S WA=$O(^WV(790.3,"B",WA)) Q:WA'>0 D
161 .S WB=0 F S WB=$O(^WV(790.3,"B",WA,WB)) Q:WB'>0 D
162 ..S N0=$G(^WV(790.3,WB,0))
163 ..N P1 F P1=1,2,3,4 S P1(P1)=$P(N0,U,P1) S:P1(P1)="" P1(P1)="NOT ENTERED"
164 ..Q:'P1(3)
165 ..S WVCN=+$P(WVREFPCE,U,+P1(3)) Q:'WVCN
166 ..S WVI(WVCN)=WVI(WVCN)+1
167 Q
168 ;
169 ;
170HELP1 ;EP
171 ;;Answer "YES" to store the results of today's snapshot after they
172 ;;have been printed out. These results can then be retrieved in the
173 ;;future (by calling up today's date) and compared to other Snapshots
174 ;;in order to look at the trends and progress of your program over
175 ;;time. (Note: If a previous snapshot for today has been run, it will
176 ;;be overwritten by this or any later run today.)
177 ;;
178 ;;Answer "NO" to simply print today's Snapshot without storing it.
179 S WVTAB=5,WVLINL="HELP1" D HELPTX
180 Q
181 ;
182HELPTX ;EP
183 N I,T,X S T=$$REPEAT^XLFSTR(" ",WVTAB)
184 F I=1:1 S X=$T(@WVLINL+I) Q:X'[";;" S DIR("?",I)=T_$P(X,";;",2)
185 S DIR("?")=DIR("?",I-1) K DIR("?",I-1)
186 Q
Note: See TracBrowser for help on using the repository browser.