source: FOIAVistA/trunk/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNAGGC.m@ 1452

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

initial load of FOIAVistA 6/30/08 version

File size: 9.6 KB
Line 
1SPNAGGC ;SD/CM- AGGREGATE CONT OF CARE OUTCOMES REPORT; 9-17-2003
2 ;;2.0;Spinal Cord Dysfunction;**20,21**;01/02/97
3 ;
4EN ;
5 S U="^"
6 D INPT^SPNAGGU
7 S (LDATE,TDATE,LORCALL,MAX1,MAX2)=0
8PARAMS ;
9 D CED
10 G:SPNLEXIT=1 EXIT
11DEVICE ;
12 S ZTSAVE("SPN*")="",ZTSAVE("B*")="",ZTSAVE("AGE*")="",ZTSAVE("MIN*")=""
13 S ZTSAVE("MAX*")="",ZTSAVE("LOR*")="",ZTSAVE("TF*")="",ZTSAVE("SEX*")=""
14 S ZTSAVE("SL*")="",ZTSAVE("COMD*")="",ZTSAVE("CARETYP")=""
15 S ZTSAVE("EDATE")="",ZTSAVE("BDATE")="",ZTSAVE("LINE")="",ZTSAVE("I")=""
16 S ZTSAVE("ASIA*")="",ZTSAVE("LDATE")="",ZTSAVE("TDATE")=""
17 W !
18 D DEVICE^SPNPRTMT("PRINT^SPNAGGPC","Continuum of Care Outcomes",.ZTSAVE) Q:SPNLEXIT
19 I SPNIO="Q" D EXIT Q ; Print was queued
20 I IO'="" D PRINT^SPNAGGPC D EXIT Q ; Print not queued
21 D EXIT
22 Q
23CED ;
24 D DATE^SPNAGGA
25 Q
26OIEN ;
27 S SPNPD1=0 F S SPNPD1=$O(^SPNL(154.1,"B",SPNPD0,SPNPD1)) Q:'+SPNPD1 D DIAGCAT
28 Q
29DIAGCAT ;
30 S SPNDCS=0,SPNDCM=0,SPNDCP=0,SPNDCL=0
31 Q:'$D(^SPNL(154.1,SPNPD1,0))
32 Q:'$D(^SPNL(154.1,SPNPD1,"ASIA"))
33 Q:'$D(^SPNL(154.1,SPNPD1,8))
34 Q:$P(^SPNL(154.1,SPNPD1,0),U,2)'=3
35 Q:$P(^SPNL(154.1,SPNPD1,8),U,3)'=CARETYP
36 Q:$P($G(^SPNL(154.1,SPNPD1,0)),U,4)<BDATE!($P($G(^SPNL(154.1,SPNPD1,0)),U,4)>EDATE)
37 Q:$P($G(^SPNL(154.1,SPNPD1,0)),U,1)=SPNNODUP
38 S SPNNODUP=$P($G(^SPNL(154.1,SPNPD1,0)),U,1)
39 S ASIAONE=$P($G(^SPNL(154.1,SPNPD1,"ASIA")),U,1),ASIAFRTN=$P($G(^SPNL(154.1,SPNPD1,"ASIA")),U,14)
40 I "ABC"[ASIAONE,ASIAFRTN<5 S SPNDCS=1
41 I "ABC"[ASIAONE,ASIAFRTN<5 S SPNLSTDT="S"
42 I "ABC"[ASIAONE&(ASIAFRTN>4)&(ASIAFRTN<9) S SPNDCM=1
43 I "ABC"[ASIAONE&(ASIAFRTN>4)&(ASIAFRTN<9) S SPNLSTDT="M"
44 I "ABC"[ASIAONE,ASIAFRTN>8 S SPNDCP=1
45 I "ABC"[ASIAONE,ASIAFRTN>8 S SPNLSTDT="P"
46 I ASIAONE="D",ASIAFRTN<31 S SPNDCL=1
47 I ASIAONE="D",ASIAFRTN<31 S SPNLSTDT="L"
48 I SPNLSTDT="S" S SPNSEVC=SPNSEVC+1
49 I SPNLSTDT="M" S SPNMODC=SPNMODC+1
50 I SPNLSTDT="P" S SPNPARC=SPNPARC+1
51 I SPNLSTDT="L" S SPNLOWC=SPNLOWC+1
52 S SPNDIAGC=SPNDIAGC+1
53 ;
54AGE ;
55 S AGECALL=$$GET1^DIQ(154.1,SPNPD1,999.025)
56 I +SPNDCS S SPNAGES=SPNAGES+AGECALL,AGESC=AGESC+1 S:AGESC=1 BMAS=AGECALL S MINAGES=$S(AGECALL<BMAS:AGECALL,1:BMAS)
57 I +SPNDCS S:AGESC=1 BHAS=AGECALL S MAXAGES=$S(AGECALL>BHAS:AGECALL,1:BHAS)
58 I +SPNDCM S SPNAGEM=SPNAGEM+AGECALL,AGEMC=AGEMC+1 S:AGEMC=1 BMAM=AGECALL S MINAGEM=$S(AGECALL<BMAM:AGECALL,1:BMAM)
59 I +SPNDCM S:AGEMC=1 BHAM=AGECALL S MAXAGEM=$S(AGECALL>BHAM:AGECALL,1:BHAM)
60 I +SPNDCP S SPNAGEP=SPNAGEP+AGECALL,AGEPC=AGEPC+1 S:AGEPC=1 BMAP=AGECALL S MINAGEP=$S(AGECALL<BMAP:AGECALL,1:BMAP)
61 I +SPNDCP S:AGEPC=1 BHAP=AGECALL S MAXAGEP=$S(AGECALL>BHAP:AGECALL,1:BHAP)
62 I +SPNDCL S SPNAGEL=SPNAGEL+AGECALL,AGELC=AGELC+1 S:AGELC=1 BMAL=AGECALL S MINAGEL=$S(AGECALL<BMAL:AGECALL,1:BMAL)
63 I +SPNDCL S:AGELC=1 BHAL=AGECALL S MAXAGEL=$S(AGECALL>BHAL:AGECALL,1:BHAL)
64 S AGEL=$S((MINAGES<MINAGEM)&(MINAGES<MINAGEP)&(MINAGES<MINAGEL):MINAGES,(MINAGEM<MINAGEP)&(MINAGEM<MINAGEL):MINAGEM,MINAGEP<MINAGEL:MINAGEP,1:MINAGEL)
65 S AGEH=$S((MAXAGES>MAXAGEM)&(MAXAGES>MAXAGEP)&(MAXAGES>MAXAGEL):MAXAGES,(MAXAGEM>MAXAGEP)&(MAXAGEM>MAXAGEL):MAXAGEM,MAXAGEP>MAXAGEL:MAXAGEP,1:MAXAGEL)
66 ;
67SEX ;
68 S SEXCALL=$P(^DPT($P(^SPNL(154.1,SPNPD1,0),U,1),0),U,2)
69 I +SPNDCS,SEXCALL="M" S SPNSEXS=SPNSEXS+1
70 I +SPNDCM,SEXCALL="M" S SPNSEXM=SPNSEXM+1
71 I +SPNDCP,SEXCALL="M" S SPNSEXP=SPNSEXP+1
72 I +SPNDCL,SEXCALL="M" S SPNSEXL=SPNSEXL+1
73LOR ;
74 I +SPNDCS D STATS I +LORRN S SPNLORS=SPNLORS+LORCALL,LORSC=LORSC+1
75 I +SPNDCS S ^TMP($J,"SPNLSNS",SPNPD1)=LORCALL S MINLORS=$$MINLOS(SPNPD1)
76 I +SPNDCS S ^TMP($J,"SPNLSXS",SPNPD1)=LORCALL S MAXLORS=$$MAXLOS(SPNPD1)
77 I +SPNDCS&(+LORRN)&(+TFSRN) S TFS=TFSCALL,TFF=LOR5CALL,TFCUMS=TFCUMS+(TFF-TFS),TFCS=TFCS+1
78 I +SPNDCS&(+LORRN)&(+TFGRN) S TFG=TFGCALL,TFF=LOR5CALL,TFGCUMS=TFGCUMS+(TFF-TFG),TFGCS=TFGCS+1
79CDSEV I +SPNDCS&(+LORRN)&($P($G(^SPNL(154.1,LORRN,0)),U,24)<5) S COMDISS=COMDISS+1
80FRETSEV I +SPNDCS&(+LORRN)&(+TFURN) S TFU=TFUCALL,TFF=LOR5CALL,TFUCUMS=TFUCUMS+(TFU-TFF),TFUCS=TFUCS+1
81SLSEV I +SPNDCS&(+SLSRN)&(+SLFRN) S SLS=SLSCALL,SLF=SLFCALL,SLCUMS=SLCUMS+(SLF-SLS),SLCS=SLCS+1
82SLUSEV I +SPNDCS&(+SLFRN)&(+SLURN) S SLU=SLUCALL,SLF=SLFCALL,SLUCUMS=SLUCUMS+(SLU-SLF),SLUCS=SLUCS+1
83 I +SPNDCM D STATS I +LORRN S SPNLORM=SPNLORM+LORCALL,LORMC=LORMC+1
84 I +SPNDCM S ^TMP($J,"SPNLSNM",SPNPD1)=LORCALL S MINLORM=$$MINLOM(SPNPD1)
85 I +SPNDCM S ^TMP($J,"SPNLSXM",SPNPD1)=LORCALL S MAXLORM=$$MAXLOM(SPNPD1)
86 I +SPNDCM&(+LORRN)&(+TFSRN) S TFS=TFSCALL,TFF=LOR5CALL,TFCUMM=TFCUMM+(TFF-TFS),TFCM=TFCM+1
87 I +SPNDCM&(+LORRN)&(+TFGRN) S TFG=TFGCALL,TFF=LOR5CALL,TFGCUMM=TFGCUMM+(TFF-TFG),TFGCM=TFGCM+1
88CDMOD I +SPNDCM&(+LORRN)&($P($G(^SPNL(154.1,LORRN,0)),U,24)<5) S COMDISM=COMDISM+1
89FRETMOD I +SPNDCM&(+LORRN)&(+TFURN) S TFU=TFUCALL,TFF=LOR5CALL,TFUCUMM=TFUCUMM+(TFU-TFF),TFUCM=TFUCM+1
90SLMOD I +SPNDCM&(+SLSRN)&(+SLFRN) S SLS=SLSCALL,SLF=SLFCALL,SLCUMM=SLCUMM+(SLF-SLS),SLCM=SLCM+1
91SLUMOD I +SPNDCM&(+SLFRN)&(+SLURN) S SLU=SLUCALL,SLF=SLFCALL,SLUCUMM=SLUCUMM+(SLU-SLF),SLUCM=SLUCM+1
92 I +SPNDCP D STATS I +LORRN S SPNLORP=SPNLORP+LORCALL,LORPC=LORPC+1
93 I +SPNDCP S ^TMP($J,"SPNLSNP",SPNPD1)=LORCALL S MINLORP=$$MINLOP(SPNPD1)
94 I +SPNDCP S ^TMP($J,"SPNLSXP",SPNPD1)=LORCALL S MAXLORP=$$MAXLOP(SPNPD1)
95 I +SPNDCP&(+LORRN)&(+TFSRN) S TFS=TFSCALL,TFF=LOR5CALL,TFCUMP=TFCUMP+(TFF-TFS),TFCP=TFCP+1
96 I +SPNDCP&(+LORRN)&(+TFGRN) S TFG=TFGCALL,TFF=LOR5CALL,TFGCUMP=TFGCUMP+(TFF-TFG),TFGCP=TFGCP+1
97CDPARA I +SPNDCP&(+LORRN)&($P($G(^SPNL(154.1,LORRN,0)),U,24)<5) S COMDISP=COMDISP+1
98FRETPAR I +SPNDCP&(+LORRN)&(+TFURN) S TFU=TFUCALL,TFF=LOR5CALL,TFUCUMP=TFUCUMP+(TFU-TFF),TFUCP=TFUCP+1
99SLPAR I +SPNDCP&(+SLSRN)&(+SLFRN) S SLS=SLSCALL,SLF=SLFCALL,SLCUMP=SLCUMP+(SLF-SLS),SLCP=SLCP+1
100SLUPAR I +SPNDCP&(+SLFRN)&(+SLURN) S SLU=SLUCALL,SLF=SLFCALL,SLUCUMP=SLUCUMP+(SLU-SLF),SLUCP=SLUCP+1
101 I +SPNDCL D STATS I +LORRN S SPNLORL=SPNLORL+LORCALL,LORLC=LORLC+1
102 I +SPNDCL S ^TMP($J,"SPNLSNL",SPNPD1)=LORCALL S MINLORL=$$MINLOL(SPNPD1)
103 I +SPNDCL S ^TMP($J,"SPNLSXL",SPNPD1)=LORCALL S MAXLORL=$$MAXLOL(SPNPD1)
104 I +SPNDCL&(+LORRN)&(+TFSRN) S TFS=TFSCALL,TFF=LOR5CALL,TFCUML=TFCUML+(TFF-TFS),TFCL=TFCL+1
105 I +SPNDCL&(+LORRN)&(+TFGRN) S TFG=TFGCALL,TFF=LOR5CALL,TFGCUML=TFGCUML+(TFF-TFG),TFGCL=TFGCL+1
106CDLOW I +SPNDCL&(+LORRN)&($P($G(^SPNL(154.1,LORRN,0)),U,24)<5) S COMDISL=COMDISL+1
107FRETLOW I +SPNDCL&(+LORRN)&(+TFURN) S TFU=TFUCALL,TFF=LOR5CALL,TFUCUML=TFUCUML+(TFU-TFF),TFUCL=TFUCL+1
108SLLOW I +SPNDCL&(+SLSRN)&(+SLFRN) S SLS=SLSCALL,SLF=SLFCALL,SLCUML=SLCUML+(SLF-SLS),SLCL=SLCL+1
109SLULOW I +SPNDCL&(+SLFRN)&(+SLURN) S SLU=SLUCALL,SLF=SLFCALL,SLUCUML=SLUCUML+(SLU-SLF),SLUCL=SLUCL+1
110 S LORL=$S((MINLORS<MINLORM)&(MINLORS<MINLORP)&(MINLORS<MINLORL):MINLORS,(MINLORM<MINLORP)&(MINLORM<MINLORL):MINLORM,MINLORP<MINLORL:MINLORP,1:MINLORL)
111 S LORH=$S((MAXLORS>MAXLORM)&(MAXLORS>MAXLORP)&(MAXLORS>MAXLORL):MAXLORS,(MAXLORM>MAXLORP)&(MAXLORM>MAXLORL):MAXLORM,MAXLORP>MAXLORL:MAXLORP,1:MAXLORL)
112 Q
113 ;
114STATS ;
115 S LORRN=0,TFSRN=0,TFGRN=0,TFURN=0,SLSRN=0,SLFRN=0,SLURN=0,LDATE=0,TDATE=0,LORCALL=0
116 S V=SPNPD1 F S V=$O(^SPNL(154.1,"B",SPNPD0,V)) Q:'+V D GETLOR
117 S LDATE=$P($G(^SPNL(154.1,LORRN,0)),U,4),TDATE=$P($G(^SPNL(154.1,TFSRN,0)),U,4)
118 I +LDATE,(+TDATE) S LORCALL=$$FMDIFF^XLFDT(LDATE,TDATE)
119 S LOR5CALL=$$GET1^DIQ(154.1,LORRN,999.05)
120 S TFSCALL=$$GET1^DIQ(154.1,TFSRN,999.05)
121 S TFGCALL=$$GET1^DIQ(154.1,TFGRN,999.05)
122 S TFUCALL=$$GET1^DIQ(154.1,TFURN,999.05)
123 S SLSCALL=$P($G(^SPNL(154.1,SLSRN,"SCORE")),U,1)
124 S SLFCALL=$P($G(^SPNL(154.1,SLFRN,"SCORE")),U,1)
125 S SLUCALL=$P($G(^SPNL(154.1,SLURN,"SCORE")),U,1)
126 Q
127GETLOR ;get Rec No. for LOR,TFS (TFF same RN as LOR), etc
128 ;LORRN is ~TFDRN
129 Q:'$D(^SPNL(154.1,V,0))
130 Q:'+$P($G(^SPNL(154.1,V,2)),U,17)
131 Q:$P($G(^SPNL(154.1,V,8)),U,3)'=CARETYP
132 Q:$P($G(^SPNL(154.1,V,0)),U,4)<BDATE!($P($G(^SPNL(154.1,V,0)),U,4)>EDATE)
133 I $P(^SPNL(154.1,V,2),U,17)=12,($P(^SPNL(154.1,V,0),U,2)=2) S TFSRN=V
134 I $P(^SPNL(154.1,V,2),U,17)=13,($P(^SPNL(154.1,V,0),U,2)=2) S TFGRN=V
135 I $P(^SPNL(154.1,V,2),U,17)=15,($P(^SPNL(154.1,V,0),U,2)=2) S LORRN=V
136 I $P(^SPNL(154.1,V,2),U,17)=16,($P(^SPNL(154.1,V,0),U,2)=2) S TFURN=V
137 I $P(^SPNL(154.1,V,2),U,17)=12,($P(^SPNL(154.1,V,0),U,2)=6) S SLSRN=V
138 I $P(^SPNL(154.1,V,2),U,17)=15,($P(^SPNL(154.1,V,0),U,2)=6) S SLFRN=V
139 I $P(^SPNL(154.1,V,2),U,17)=16,($P(^SPNL(154.1,V,0),U,2)=6) S SLURN=V
140 Q
141MAXLOS(SPNPD1) ;
142 S MAX1=0
143 S X=0 F S X=$O(^TMP($J,"SPNLSXS",X)) Q:'+X D
144 .Q:'$D(^TMP($J,"SPNLSXS",X))
145 .S MAX2=$P(^TMP($J,"SPNLSXS",X),U,1)
146 .I MAX2>MAX1 S MAX1=MAX2
147 .Q
148 Q MAX1
149MAXLOM(SPNPD1) ;
150 S MAX1=0
151 S X=0 F S X=$O(^TMP($J,"SPNLSXM",X)) Q:'+X D
152 .Q:'$D(^TMP($J,"SPNLSXM",X))
153 .S MAX2=$P(^TMP($J,"SPNLSXM",X),U,1)
154 .I MAX2>MAX1 S MAX1=MAX2
155 .Q
156 Q MAX1
157MAXLOP(SPNPD1) ;
158 S MAX1=0
159 S X=0 F S X=$O(^TMP($J,"SPNLSXP",X)) Q:'+X D
160 .Q:'$D(^TMP($J,"SPNLSXP",X))
161 .S MAX2=$P(^TMP($J,"SPNLSXP",X),U,1)
162 .I MAX2>MAX1 S MAX1=MAX2
163 .Q
164 Q MAX1
165MAXLOL(SPNPD1) ;
166 S MAX1=0
167 S X=0 F S X=$O(^TMP($J,"SPNLSXL",X)) Q:'+X D
168 .Q:'$D(^TMP($J,"SPNLSXL",X))
169 .S MAX2=$P(^TMP($J,"SPNLSXL",X),U,1)
170 .I MAX2>MAX1 S MAX1=MAX2
171 .Q
172 Q MAX1
173MINLOS(SPNPD1) ;
174 S MAX1=LORCALL
175 S X=0 F S X=$O(^TMP($J,"SPNLSNS",X)) Q:'+X D
176 .Q:'$D(^TMP($J,"SPNLSNS",X))
177 .S MAX2=$P(^TMP($J,"SPNLSNS",X),U,1)
178 .I MAX2<MAX1 S MAX1=MAX2
179 .Q
180 Q MAX1
181MINLOM(SPNPD1) ;
182 S MAX1=LORCALL
183 S X=0 F S X=$O(^TMP($J,"SPNLSNM",X)) Q:'+X D
184 .Q:'$D(^TMP($J,"SPNLSNM",X))
185 .S MAX2=$P(^TMP($J,"SPNLSNM",X),U,1)
186 .I MAX2<MAX1 S MAX1=MAX2
187 .Q
188 Q MAX1
189MINLOP(SPNPD1) ;
190 S MAX1=LORCALL
191 S X=0 F S X=$O(^TMP($J,"SPNLSNP",X)) Q:'+X D
192 .Q:'$D(^TMP($J,"SPNLSNP",X))
193 .S MAX2=$P(^TMP($J,"SPNLSNP",X),U,1)
194 .I MAX2<MAX1 S MAX1=MAX2
195 .Q
196 Q MAX1
197MINLOL(SPNPD1) ;
198 S MAX1=LORCALL
199 S X=0 F S X=$O(^TMP($J,"SPNLSNL",X)) Q:'+X D
200 .Q:'$D(^TMP($J,"SPNLSNL",X))
201 .S MAX2=$P(^TMP($J,"SPNLSNL",X),U,1)
202 .I MAX2<MAX1 S MAX1=MAX2
203 .Q
204 Q MAX1
205EXIT ;
206 D EXIT^SPNAGGU
207 K LDATE,TDATE,MAX1,MAX2
208 K ^TMP($J,"SPNLSXS"),^TMP($J,"SPNLSXM"),^TMP($J,"SPNLSXP"),^TMP($J,"SPNLSXL")
209 K ^TMP($J,"SPNLSNS"),^TMP($J,"SPNLSNM"),^TMP($J,"SPNLSNP"),^TMP($J,"SPNLSNL")
210 Q
Note: See TracBrowser for help on using the repository browser.