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

PXRMG2S1 ;SLC/JVS -GEC #2 SORTING INFORMATION #1  ;2/13/05  20:05
 ;;2.0;CLINICAL REMINDERS;**2**;Feb 04, 2005
 Q
 ;
C1(REF) ;Check for Criteria 1 qualifications 3 ADL's
 N ARY,C1CNT,ELIGIBLE
 S C1CNT=0,ELIGIBLE=0
 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
 I $D(@ARY@(REF,$O(C212(0)))) S C1CNT=C1CNT+1
 I $D(@ARY@(REF,$O(C216(0)))) S C1CNT=C1CNT+1
 I $D(@ARY@(REF,$O(C218(0)))) S C1CNT=C1CNT+1
 I $D(@ARY@(REF,$O(C2110(0)))) S C1CNT=C1CNT+1
 I $D(@ARY@(REF,$O(C2114(0)))) S C1CNT=C1CNT+1
 I $D(@ARY@(REF,$O(C2118(0)))) S C1CNT=C1CNT+1
 I $D(@ARY@(REF,$O(C2120(0)))) S C1CNT=C1CNT+1
 I C1CNT>2 S ELIGIBLE=1
 Q ELIGIBLE
 ;
C2(REF) ;Check for Criteria 2 qualifications 1 "Cognitive Impairment"
 N ARY,C2CNT,ELIGIBLE
 S C2CNT=0,ELIGIBLE=0
 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
 I $D(@ARY@(REF,$O(C221(0)))) S C2CNT=C2CNT+1
 I $D(@ARY@(REF,$O(C224(0)))) S C2CNT=C2CNT+1
 I $D(@ARY@(REF,$O(C226(0)))) S C2CNT=C2CNT+1
 I $D(@ARY@(REF,$O(C272(0)))) S C2CNT=C2CNT+1
 I $D(@ARY@(REF,$O(C274(0)))) S C2CNT=C2CNT+1
 I $D(@ARY@(REF,$O(C276(0)))) S C2CNT=C2CNT+1
 I $D(@ARY@(REF,$O(C278(0)))) S C2CNT=C2CNT+1
 I $D(@ARY@(REF,$O(C2710(0)))) S C2CNT=C2CNT+1
 I C2CNT>0 S ELIGIBLE=1
 Q ELIGIBLE
 ;
 ;
C3(REF) ;Check for Criteria 3 qualifications 1 "Life Expectancy<6mo"
 N ARY,C3CNT,ELIGIBLE
 S C3CNT=0,ELIGIBLE=0
 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
 I $D(@ARY@(REF,$O(C286(0)))) S C3CNT=C3CNT+1
 I C3CNT>0 S ELIGIBLE=1
 Q ELIGIBLE
 ;
C4(REF) ;Check for Criteria 4 qualifications 2 OR MORE ADL's
 N ARY,C4ACNT,ELIGIBLE,C4BCNT,C4FCNT,AGEF,AGEO,C4CCNT,PXRMAPT,APPTF
 N NAME,APPTO,HFDA,SSN,DATE,PROG
 S C4ACNT=0,ELIGIBLE=0,C4BCNT=0,C4FCNT=0,C4CCNT=0
 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
 S HFDA=$O(@ARY@(REF,0))
 ;---AGE---
 ;S AGEO=$O(@ARY@(REF,0))
 S AGEF=$O(@ARY@(REF,HFDA,-1))
 ;---AGE-----
 ;---APPOINTMENTS---
 S APPTF=0
 S APPTO=$O(@ARY@(REF,HFDA,AGEF,-1))
 I APPTO>12 S APPTF=1
 ;---APPOINTMENTS---
 ;---NAME AND SSN---
 S NAME=$O(@ARY@(REF,HFDA,AGEF,APPTO,0))
 ;---NAME AND SSN---
 ;---MONTH
 S MONTH=$O(@ARY@(REF,HFDA,AGEF,APPTO,NAME,0))
 ;---MONTH
 ;---SSN
 S SSN=$O(@ARY@(REF,HFDA,AGEF,APPTO,NAME,MONTH,""))
 ;---SSN
 ;---DATE
 S DATE=$O(@ARY@(REF,HFDA,AGEF,APPTO,NAME,MONTH,SSN,0))
 ;---DATE
 ;---PROGRAM
 S PROG=$$PROG(REF)
 ;---PROGRAM
 I $D(@ARY@(REF,$O(C212(0)))) S C4ACNT=C4ACNT+1
 I $D(@ARY@(REF,$O(C216(0)))) S C4ACNT=C4ACNT+1
 I $D(@ARY@(REF,$O(C218(0)))) S C4ACNT=C4ACNT+1
 I $D(@ARY@(REF,$O(C2110(0)))) S C4ACNT=C4ACNT+1
 I $D(@ARY@(REF,$O(C2114(0)))) S C4ACNT=C4ACNT+1
 I $D(@ARY@(REF,$O(C2118(0)))) S C4ACNT=C4ACNT+1
 I $D(@ARY@(REF,$O(C2120(0)))) S C4ACNT=C4ACNT+1
 I $D(@ARY@(REF,$O(C142(0)))) S C4BCNT=C4BCNT+1
 I $D(@ARY@(REF,$O(C144(0)))) S C4BCNT=C4BCNT+1
 I $D(@ARY@(REF,$O(C146(0)))) S C4BCNT=C4BCNT+1
 I $D(@ARY@(REF,$O(C148(0)))) S C4BCNT=C4BCNT+1
 I $D(@ARY@(REF,$O(C1410(0)))) S C4BCNT=C4BCNT+1
 I $D(@ARY@(REF,$O(C1412(0)))) S C4BCNT=C4BCNT+1
 I $D(@ARY@(REF,$O(C1414(0)))) S C4BCNT=C4BCNT+1
 I $D(@ARY@(REF,$O(C1101(0)))) S C4CCNT=C4CCNT+1
 I $D(@ARY@(REF,$O(C1107(0)))) S C4CCNT=C4CCNT+1
 I $D(@ARY@(REF,$O(C1108(0)))) S C4CCNT=C4CCNT+1
 I $D(@ARY@(REF,$O(C171(0)))) S C4FCNT=C4FCNT+1
 I $D(@ARY@(REF,$O(C166(0)))) S C4FCNT=C4FCNT+1
 ;--EVALUATION--
 N ELI
 S ELI=0
 I C4BCNT>2 S ELI=ELI+1
 I C4CCNT>0 S ELI=ELI+1
 I AGEF=1 S ELI=ELI+1
 I APPTF=1 S ELI=ELI+1
 I C4FCNT>0 S ELI=ELI+1
 ;
 I C4ACNT>1,ELI>1 S ELIGIBLE=1
 ;--EVALUATION--
 S ELIGIBLE=ELIGIBLE_"^"_NAME_"^"_MONTH_"^"_SSN_"^"_DATE_"^"_PROG
 Q ELIGIBLE
 ;=============================================
PROG(REF) ;Determind Program (FUNCTION)
 N ARY,PROG
 S PROG="NONE"
 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
 I $D(@ARY@(REF,$O(P441(0)))),$D(@ARY@(REF,$O(P449(0)))) D
 .S PROG="ADHC"
 I $D(@ARY@(REF,$O(P4410(0)))),$D(@ARY@(REF,$O(P449(0)))) D
 .S PROG="HHHA"
 I $D(@ARY@(REF,$O(P4412(0)))),$D(@ARY@(REF,$O(P449(0)))) D
 .S PROG="VAIHR"
 I $D(@ARY@(REF,$O(P451(0)))),$D(@ARY@(REF,$O(P452(0)))) D
 .S PROG="CC"
 Q PROG