| 1 | WVRPSNP ;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 | ;
|
|---|
| 20 | EXIT ;EP
|
|---|
| 21 | D KILLALL^WVUTL8
|
|---|
| 22 | K ^TMP("WVF",$J)
|
|---|
| 23 | Q
|
|---|
| 24 | ;
|
|---|
| 25 | ASKTOY ;
|
|---|
| 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
|
|---|
| 36 | DEVICE ;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 | ;
|
|---|
| 44 | ASKSAVE ;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 | ;
|
|---|
| 56 | DEQUEUE ;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 | ;
|
|---|
| 62 | STORE ;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 | ;
|
|---|
| 84 | GATHER ;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
|
|---|
| 149 | R ;---> 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 | ;
|
|---|
| 170 | HELP1 ;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 | ;
|
|---|
| 182 | HELPTX ;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
|
|---|
