source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMG2S1.m@ 1119

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1PXRMG2S1 ;SLC/JVS -GEC #2 SORTING INFORMATION #1 ;2/13/05 20:05
2 ;;2.0;CLINICAL REMINDERS;**2**;Feb 04, 2005
3 Q
4 ;
5C1(REF) ;Check for Criteria 1 qualifications 3 ADL's
6 N ARY,C1CNT,ELIGIBLE
7 S C1CNT=0,ELIGIBLE=0
8 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
9 I $D(@ARY@(REF,$O(C212(0)))) S C1CNT=C1CNT+1
10 I $D(@ARY@(REF,$O(C216(0)))) S C1CNT=C1CNT+1
11 I $D(@ARY@(REF,$O(C218(0)))) S C1CNT=C1CNT+1
12 I $D(@ARY@(REF,$O(C2110(0)))) S C1CNT=C1CNT+1
13 I $D(@ARY@(REF,$O(C2114(0)))) S C1CNT=C1CNT+1
14 I $D(@ARY@(REF,$O(C2118(0)))) S C1CNT=C1CNT+1
15 I $D(@ARY@(REF,$O(C2120(0)))) S C1CNT=C1CNT+1
16 I C1CNT>2 S ELIGIBLE=1
17 Q ELIGIBLE
18 ;
19C2(REF) ;Check for Criteria 2 qualifications 1 "Cognitive Impairment"
20 N ARY,C2CNT,ELIGIBLE
21 S C2CNT=0,ELIGIBLE=0
22 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
23 I $D(@ARY@(REF,$O(C221(0)))) S C2CNT=C2CNT+1
24 I $D(@ARY@(REF,$O(C224(0)))) S C2CNT=C2CNT+1
25 I $D(@ARY@(REF,$O(C226(0)))) S C2CNT=C2CNT+1
26 I $D(@ARY@(REF,$O(C272(0)))) S C2CNT=C2CNT+1
27 I $D(@ARY@(REF,$O(C274(0)))) S C2CNT=C2CNT+1
28 I $D(@ARY@(REF,$O(C276(0)))) S C2CNT=C2CNT+1
29 I $D(@ARY@(REF,$O(C278(0)))) S C2CNT=C2CNT+1
30 I $D(@ARY@(REF,$O(C2710(0)))) S C2CNT=C2CNT+1
31 I C2CNT>0 S ELIGIBLE=1
32 Q ELIGIBLE
33 ;
34 ;
35C3(REF) ;Check for Criteria 3 qualifications 1 "Life Expectancy<6mo"
36 N ARY,C3CNT,ELIGIBLE
37 S C3CNT=0,ELIGIBLE=0
38 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
39 I $D(@ARY@(REF,$O(C286(0)))) S C3CNT=C3CNT+1
40 I C3CNT>0 S ELIGIBLE=1
41 Q ELIGIBLE
42 ;
43C4(REF) ;Check for Criteria 4 qualifications 2 OR MORE ADL's
44 N ARY,C4ACNT,ELIGIBLE,C4BCNT,C4FCNT,AGEF,AGEO,C4CCNT,PXRMAPT,APPTF
45 N NAME,APPTO,HFDA,SSN,DATE,PROG
46 S C4ACNT=0,ELIGIBLE=0,C4BCNT=0,C4FCNT=0,C4CCNT=0
47 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
48 S HFDA=$O(@ARY@(REF,0))
49 ;---AGE---
50 ;S AGEO=$O(@ARY@(REF,0))
51 S AGEF=$O(@ARY@(REF,HFDA,-1))
52 ;---AGE-----
53 ;---APPOINTMENTS---
54 S APPTF=0
55 S APPTO=$O(@ARY@(REF,HFDA,AGEF,-1))
56 I APPTO>12 S APPTF=1
57 ;---APPOINTMENTS---
58 ;---NAME AND SSN---
59 S NAME=$O(@ARY@(REF,HFDA,AGEF,APPTO,0))
60 ;---NAME AND SSN---
61 ;---MONTH
62 S MONTH=$O(@ARY@(REF,HFDA,AGEF,APPTO,NAME,0))
63 ;---MONTH
64 ;---SSN
65 S SSN=$O(@ARY@(REF,HFDA,AGEF,APPTO,NAME,MONTH,""))
66 ;---SSN
67 ;---DATE
68 S DATE=$O(@ARY@(REF,HFDA,AGEF,APPTO,NAME,MONTH,SSN,0))
69 ;---DATE
70 ;---PROGRAM
71 S PROG=$$PROG(REF)
72 ;---PROGRAM
73 I $D(@ARY@(REF,$O(C212(0)))) S C4ACNT=C4ACNT+1
74 I $D(@ARY@(REF,$O(C216(0)))) S C4ACNT=C4ACNT+1
75 I $D(@ARY@(REF,$O(C218(0)))) S C4ACNT=C4ACNT+1
76 I $D(@ARY@(REF,$O(C2110(0)))) S C4ACNT=C4ACNT+1
77 I $D(@ARY@(REF,$O(C2114(0)))) S C4ACNT=C4ACNT+1
78 I $D(@ARY@(REF,$O(C2118(0)))) S C4ACNT=C4ACNT+1
79 I $D(@ARY@(REF,$O(C2120(0)))) S C4ACNT=C4ACNT+1
80 I $D(@ARY@(REF,$O(C142(0)))) S C4BCNT=C4BCNT+1
81 I $D(@ARY@(REF,$O(C144(0)))) S C4BCNT=C4BCNT+1
82 I $D(@ARY@(REF,$O(C146(0)))) S C4BCNT=C4BCNT+1
83 I $D(@ARY@(REF,$O(C148(0)))) S C4BCNT=C4BCNT+1
84 I $D(@ARY@(REF,$O(C1410(0)))) S C4BCNT=C4BCNT+1
85 I $D(@ARY@(REF,$O(C1412(0)))) S C4BCNT=C4BCNT+1
86 I $D(@ARY@(REF,$O(C1414(0)))) S C4BCNT=C4BCNT+1
87 I $D(@ARY@(REF,$O(C1101(0)))) S C4CCNT=C4CCNT+1
88 I $D(@ARY@(REF,$O(C1107(0)))) S C4CCNT=C4CCNT+1
89 I $D(@ARY@(REF,$O(C1108(0)))) S C4CCNT=C4CCNT+1
90 I $D(@ARY@(REF,$O(C171(0)))) S C4FCNT=C4FCNT+1
91 I $D(@ARY@(REF,$O(C166(0)))) S C4FCNT=C4FCNT+1
92 ;--EVALUATION--
93 N ELI
94 S ELI=0
95 I C4BCNT>2 S ELI=ELI+1
96 I C4CCNT>0 S ELI=ELI+1
97 I AGEF=1 S ELI=ELI+1
98 I APPTF=1 S ELI=ELI+1
99 I C4FCNT>0 S ELI=ELI+1
100 ;
101 I C4ACNT>1,ELI>1 S ELIGIBLE=1
102 ;--EVALUATION--
103 S ELIGIBLE=ELIGIBLE_"^"_NAME_"^"_MONTH_"^"_SSN_"^"_DATE_"^"_PROG
104 Q ELIGIBLE
105 ;=============================================
106PROG(REF) ;Determind Program (FUNCTION)
107 N ARY,PROG
108 S PROG="NONE"
109 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
110 I $D(@ARY@(REF,$O(P441(0)))),$D(@ARY@(REF,$O(P449(0)))) D
111 .S PROG="ADHC"
112 I $D(@ARY@(REF,$O(P4410(0)))),$D(@ARY@(REF,$O(P449(0)))) D
113 .S PROG="HHHA"
114 I $D(@ARY@(REF,$O(P4412(0)))),$D(@ARY@(REF,$O(P449(0)))) D
115 .S PROG="VAIHR"
116 I $D(@ARY@(REF,$O(P451(0)))),$D(@ARY@(REF,$O(P452(0)))) D
117 .S PROG="CC"
118 Q PROG
Note: See TracBrowser for help on using the repository browser.