Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMG2S1

PXRMG2S1.m

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