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

AGGELCHK.m

Go to the documentation of this file. 
  1. AGGELCHK ;VNGT/HS/ALA - Eligibility Checks ; 24 May 2010  6:44 PM
  1.  ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
  1.  ;
  1.  ;
  1. EN(AGB,AGTP,AGQT,AGQI,AGEL) ; EP - AGG ELIGIBILITY VALID
  1.  ; Input parameters
  1.  ;   AGB  = AGGPTCLB = Classification/Beneficiary
  1.  ;   AGTP = AGGPTTRI = Tribe of Membership
  1.  ;   AGQT = AGGPTTRQ = Tribe Quantum
  1.  ;   AGQI = AGGPTBLQ = Indian Blood Quantum
  1.  ;   AGEL = AGGPTELG = Eligibility Status
  1.  ;
  1.  ;NEW UID,II
  1.  ;S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  ;S DATA=$NA(^TMP("AGGELCHK",UID))
  1.  ;K @DATA
  1.  ;S II=0
  1.  ;NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGELCHK D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  ;S HDR="I00010RESULT^T00030MSG"
  1.  ;S @DATA@(II)=HDR_$C(30)
  1.  ;
  1. BEN ;
  1.  I AGB']"" D  G QTCHK
  1.  . S MSG="Classification/Beneficiary Missing",RESULT=-1,CODE="AGGPTCLB"
  1.  ;
  1.  ;Skip check if classification/beneficiary is not Indian/Alaskan Native
  1.  N CLBEN
  1.  S CLBEN=$O(^AUTTBEN("B","INDIAN/ALASKA NATIVE",""))  ;Get Classification IEN
  1.  I AGB]"",AGB'=CLBEN S RESULT=1 G END
  1.  K CLBEN
  1.  ;
  1. TRIBE ;
  1.  I $L(AGTP),$D(^AUTTTRI(AGTP,0)),($P(^(0),U,4)="N"!($P(^(0),U,4)="")) S AGT=$P(^AUTTTRI(AGTP,0),U,2)
  1.  E  D  G ELIG
  1.  . S AGT=0
  1.  . I $G(AGTP)="" S MSG="Native American requires Valid Indian Tribe",RESULT=-1,CODE="AGGPTTRI" Q
  1.  . S MSG="INVALID old TRIBE",RESULT=-1,CODE="AGGPTTRI"
  1.  S AGT=+AGT
  1.  S AGB=+AGB
  1.  G:+AGB=1 IND                        ;BEN = Indian
  1.  F I=6,18,32,33,8 I +AGB=I G NON
  1.  ;all other BEN and tribe combinations are acceptable
  1.  G ELIG
  1.  ;
  1. IND ;check BEN=1 TR'=000,970
  1.  I AGT>0,AGT'=970 G ELIG
  1.  E  D
  1.  . S MSG="Native American requires Valid Indian Tribe",RESULT=-1,CODE="AGGPTTRI"
  1.  G ELIG
  1.  ;
  1. NON ;BEN - NON INDIAN TR=000,970
  1.  I AGB=8,((AGT=0)!(AGT=999)!(AGT=970)) G ELIG
  1.  E  I AGB=8 D  G ELIG
  1.  . S MSG="'OTHER' Ben/Class requires 'Non-Indian' or 'Unspecified' Tribe",RESULT=-1,CODE="AGGPTTRI"
  1.  I ((AGT=0)!(AGT=970)) G ELIG
  1.  E  D
  1.  . S MSG="'Non-Indian' Ben/Class requires 'Non-Indian' Tribe",RESULT=-1,CODE="AGGPTTRI"
  1.  G ELIG
  1.  ;
  1. ELIG ;Check Eligibility
  1.  I AGEL']"" D  G QTCHK
  1.  . S MSG="Eligibility Missing",RESULT=-1,CODE="AGGPTELG"
  1.  I ((AGB=1)!(AGB=3)!(AGB=4)),AGEL="I" D  G QTCHK
  1.  . S MSG="Ben/Class selected should be Eligible for care",RESULT=-1,CODE="AGGPTCLB"
  1.  ;
  1. TRBQT ; Check Tribe and Indian Quantum consistency
  1.  S AGTF=1
  1.  I ((AGT=0)!(AGT=970)) S AGTF=0
  1.  I AGT=999 F AGZ=6,8,18,32,33 S:AGB=AGZ AGTF=0
  1.  I AGTF,AGEL="I" S MSG="WARNING ... Valid Tribe should be Eligible for Care",RESULT=-1,CODE="AGGPTELG" G QTCHK
  1.  S AGQF=0
  1.  I "UNKNOWN,NONE"'[AGQI S AGQF=1
  1.  I AGTF=AGQF
  1.  E  D
  1.  . S MSG="Tribe Selected and Indian Quantum are Inconsistent",RESULT=-1,CODE="AGGPTTRI"
  1.  ;
  1. QTCHK ;
  1.  ;Check Quantums consistency - Now asked in quantum field validation
  1.  ;I '$G(AGSITE),'$D(^AGFAC(DUZ(2))) Q
  1.  ;I $G(AGSITE),'$D(^AGFAC(AGSITE)) Q
  1.  ;I $P(^AGFAC($S($D(AGSITE):AGSITE,1:DUZ(2)),0),"^",2)'="Y" G END
  1.  ;G:AGQT=AGQI END
  1.  ;I "UNKNOWN,NONE"'[AGQI,"UNKNOWN,NONE"'[AGQT
  1.  ;E  D
  1.  ;. S MSG="Quantums are Inconsistent",RESULT=-1,CODE="AGGPTBLQ"
  1. END ;
  1.  I RESULT'=-1 S RESULT=1,MSG="",CODE=""
  1.  K AGQF,AGT,AGTF,AGZ,CLBEN
  1.  ;S II=II+1,@DATA@(II)=RESULT_U_MSG_$C(30)
  1.  ;S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q