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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMG2S1 4016 printed Dec 13, 2024@01:45:41 Page 2
PXRMG2S1 ;SLC/JVS -GEC #2 SORTING INFORMATION #1 ;2/13/05 20:05
+1 ;;2.0;CLINICAL REMINDERS;**2**;Feb 04, 2005
+2 QUIT
+3 ;
C1(REF) ;Check for Criteria 1 qualifications 3 ADL's
+1 NEW ARY,C1CNT,ELIGIBLE
+2 SET C1CNT=0
SET ELIGIBLE=0
+3 SET ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
+4 IF $DATA(@ARY@(REF,$ORDER(C212(0))))
SET C1CNT=C1CNT+1
+5 IF $DATA(@ARY@(REF,$ORDER(C216(0))))
SET C1CNT=C1CNT+1
+6 IF $DATA(@ARY@(REF,$ORDER(C218(0))))
SET C1CNT=C1CNT+1
+7 IF $DATA(@ARY@(REF,$ORDER(C2110(0))))
SET C1CNT=C1CNT+1
+8 IF $DATA(@ARY@(REF,$ORDER(C2114(0))))
SET C1CNT=C1CNT+1
+9 IF $DATA(@ARY@(REF,$ORDER(C2118(0))))
SET C1CNT=C1CNT+1
+10 IF $DATA(@ARY@(REF,$ORDER(C2120(0))))
SET C1CNT=C1CNT+1
+11 IF C1CNT>2
SET ELIGIBLE=1
+12 QUIT ELIGIBLE
+13 ;
C2(REF) ;Check for Criteria 2 qualifications 1 "Cognitive Impairment"
+1 NEW ARY,C2CNT,ELIGIBLE
+2 SET C2CNT=0
SET ELIGIBLE=0
+3 SET ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
+4 IF $DATA(@ARY@(REF,$ORDER(C221(0))))
SET C2CNT=C2CNT+1
+5 IF $DATA(@ARY@(REF,$ORDER(C224(0))))
SET C2CNT=C2CNT+1
+6 IF $DATA(@ARY@(REF,$ORDER(C226(0))))
SET C2CNT=C2CNT+1
+7 IF $DATA(@ARY@(REF,$ORDER(C272(0))))
SET C2CNT=C2CNT+1
+8 IF $DATA(@ARY@(REF,$ORDER(C274(0))))
SET C2CNT=C2CNT+1
+9 IF $DATA(@ARY@(REF,$ORDER(C276(0))))
SET C2CNT=C2CNT+1
+10 IF $DATA(@ARY@(REF,$ORDER(C278(0))))
SET C2CNT=C2CNT+1
+11 IF $DATA(@ARY@(REF,$ORDER(C2710(0))))
SET C2CNT=C2CNT+1
+12 IF C2CNT>0
SET ELIGIBLE=1
+13 QUIT ELIGIBLE
+14 ;
+15 ;
C3(REF) ;Check for Criteria 3 qualifications 1 "Life Expectancy<6mo"
+1 NEW ARY,C3CNT,ELIGIBLE
+2 SET C3CNT=0
SET ELIGIBLE=0
+3 SET ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
+4 IF $DATA(@ARY@(REF,$ORDER(C286(0))))
SET C3CNT=C3CNT+1
+5 IF C3CNT>0
SET ELIGIBLE=1
+6 QUIT ELIGIBLE
+7 ;
C4(REF) ;Check for Criteria 4 qualifications 2 OR MORE ADL's
+1 NEW ARY,C4ACNT,ELIGIBLE,C4BCNT,C4FCNT,AGEF,AGEO,C4CCNT,PXRMAPT,APPTF
+2 NEW NAME,APPTO,HFDA,SSN,DATE,PROG
+3 SET C4ACNT=0
SET ELIGIBLE=0
SET C4BCNT=0
SET C4FCNT=0
SET C4CCNT=0
+4 SET ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
+5 SET HFDA=$ORDER(@ARY@(REF,0))
+6 ;---AGE---
+7 ;S AGEO=$O(@ARY@(REF,0))
+8 SET AGEF=$ORDER(@ARY@(REF,HFDA,-1))
+9 ;---AGE-----
+10 ;---APPOINTMENTS---
+11 SET APPTF=0
+12 SET APPTO=$ORDER(@ARY@(REF,HFDA,AGEF,-1))
+13 IF APPTO>12
SET APPTF=1
+14 ;---APPOINTMENTS---
+15 ;---NAME AND SSN---
+16 SET NAME=$ORDER(@ARY@(REF,HFDA,AGEF,APPTO,0))
+17 ;---NAME AND SSN---
+18 ;---MONTH
+19 SET MONTH=$ORDER(@ARY@(REF,HFDA,AGEF,APPTO,NAME,0))
+20 ;---MONTH
+21 ;---SSN
+22 SET SSN=$ORDER(@ARY@(REF,HFDA,AGEF,APPTO,NAME,MONTH,""))
+23 ;---SSN
+24 ;---DATE
+25 SET DATE=$ORDER(@ARY@(REF,HFDA,AGEF,APPTO,NAME,MONTH,SSN,0))
+26 ;---DATE
+27 ;---PROGRAM
+28 SET PROG=$$PROG(REF)
+29 ;---PROGRAM
+30 IF $DATA(@ARY@(REF,$ORDER(C212(0))))
SET C4ACNT=C4ACNT+1
+31 IF $DATA(@ARY@(REF,$ORDER(C216(0))))
SET C4ACNT=C4ACNT+1
+32 IF $DATA(@ARY@(REF,$ORDER(C218(0))))
SET C4ACNT=C4ACNT+1
+33 IF $DATA(@ARY@(REF,$ORDER(C2110(0))))
SET C4ACNT=C4ACNT+1
+34 IF $DATA(@ARY@(REF,$ORDER(C2114(0))))
SET C4ACNT=C4ACNT+1
+35 IF $DATA(@ARY@(REF,$ORDER(C2118(0))))
SET C4ACNT=C4ACNT+1
+36 IF $DATA(@ARY@(REF,$ORDER(C2120(0))))
SET C4ACNT=C4ACNT+1
+37 IF $DATA(@ARY@(REF,$ORDER(C142(0))))
SET C4BCNT=C4BCNT+1
+38 IF $DATA(@ARY@(REF,$ORDER(C144(0))))
SET C4BCNT=C4BCNT+1
+39 IF $DATA(@ARY@(REF,$ORDER(C146(0))))
SET C4BCNT=C4BCNT+1
+40 IF $DATA(@ARY@(REF,$ORDER(C148(0))))
SET C4BCNT=C4BCNT+1
+41 IF $DATA(@ARY@(REF,$ORDER(C1410(0))))
SET C4BCNT=C4BCNT+1
+42 IF $DATA(@ARY@(REF,$ORDER(C1412(0))))
SET C4BCNT=C4BCNT+1
+43 IF $DATA(@ARY@(REF,$ORDER(C1414(0))))
SET C4BCNT=C4BCNT+1
+44 IF $DATA(@ARY@(REF,$ORDER(C1101(0))))
SET C4CCNT=C4CCNT+1
+45 IF $DATA(@ARY@(REF,$ORDER(C1107(0))))
SET C4CCNT=C4CCNT+1
+46 IF $DATA(@ARY@(REF,$ORDER(C1108(0))))
SET C4CCNT=C4CCNT+1
+47 IF $DATA(@ARY@(REF,$ORDER(C171(0))))
SET C4FCNT=C4FCNT+1
+48 IF $DATA(@ARY@(REF,$ORDER(C166(0))))
SET C4FCNT=C4FCNT+1
+49 ;--EVALUATION--
+50 NEW ELI
+51 SET ELI=0
+52 IF C4BCNT>2
SET ELI=ELI+1
+53 IF C4CCNT>0
SET ELI=ELI+1
+54 IF AGEF=1
SET ELI=ELI+1
+55 IF APPTF=1
SET ELI=ELI+1
+56 IF C4FCNT>0
SET ELI=ELI+1
+57 ;
+58 IF C4ACNT>1
IF ELI>1
SET ELIGIBLE=1
+59 ;--EVALUATION--
+60 SET ELIGIBLE=ELIGIBLE_"^"_NAME_"^"_MONTH_"^"_SSN_"^"_DATE_"^"_PROG
+61 QUIT ELIGIBLE
+62 ;=============================================
PROG(REF) ;Determind Program (FUNCTION)
+1 NEW ARY,PROG
+2 SET PROG="NONE"
+3 SET ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
+4 IF $DATA(@ARY@(REF,$ORDER(P441(0))))
IF $DATA(@ARY@(REF,$ORDER(P449(0))))
Begin DoDot:1
+5 SET PROG="ADHC"
End DoDot:1
+6 IF $DATA(@ARY@(REF,$ORDER(P4410(0))))
IF $DATA(@ARY@(REF,$ORDER(P449(0))))
Begin DoDot:1
+7 SET PROG="HHHA"
End DoDot:1
+8 IF $DATA(@ARY@(REF,$ORDER(P4412(0))))
IF $DATA(@ARY@(REF,$ORDER(P449(0))))
Begin DoDot:1
+9 SET PROG="VAIHR"
End DoDot:1
+10 IF $DATA(@ARY@(REF,$ORDER(P451(0))))
IF $DATA(@ARY@(REF,$ORDER(P452(0))))
Begin DoDot:1
+11 SET PROG="CC"
End DoDot:1
+12 QUIT PROG
