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