AGELCHK ; IHS/ASDS/EFG - TRIBE-QUANTUM-BEN CODE CONSISTENCY CHECKER ;
;;7.1;PATIENT REGISTRATION;**4,5**;AUG 25,2005
;
; ****************************************************************
; This will return AG("ER",9)="" if the entry is inconsistant
; If AGWM is set=1 then messages will be writen out
; DFN is required
; ****************************************************************
;
SET ;
S:'$D(AGWM) AGWM=0
;AGWM is to be set prior if Writing Messages is desired
K AG("ER",9)
I $D(^AUPNPAT(DFN,11)) D
. S AG11=^AUPNPAT(DFN,11)
. S AGB=$P(AG11,U,11) ;CLASS/BENEFICIARY
. S AGTP=$P(AG11,U,8) ;TRIBE OF MEMBERSHIP
. S AGQT=$P(AG11,U,9) ;TRIBE QUANTUM
. S AGQI=$P(AG11,U,10) ;INDIAN BLOOD QUANTUM
. S AGEL=$P(AG11,U,12) ;ELIGIBILITY STATUS
E D G EXIT
. S AG("ER",9)=""
. W:AGWM !,"< Missing Eligibility, Beneficiary, Tribal Information >"
S ;
TRIBE ;
;I $L(AGTP),$D(^AUTTTRI(AGTP,0)),$P(^(0),U,4)="N" S AGT=$P(^AUTTTRI(AGTP,0),U,2)
I $L(AGTP),$D(^AUTTTRI(AGTP,0)),($P(^(0),U,4)="N"!($P(^(0),U,4)="")) S AGT=$P(^AUTTTRI(AGTP,0),U,2) ;IHS/SD/TPF AG*7.1*4 IM23957
E D G ELIG
. S AG("ER",9)=""
. S AGT=0
. W:AGWM !,"<< INVALID old TRIBE >>"
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 AG("ER",9)=""
. W:AGWM !,"<< Native American requires Valid Indian Tribe >>"
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 AG("ER",9)=""
. W:AGWM !,"< 'OTHER' Ben/Class requires 'Non-Indian' or 'Unspecified' Tribe >"
I ((AGT=0)!(AGT=970)) G ELIG
E D
. ;I AGT=990 Q ;IHS/SD/TPF H5933
. S AG("ER",9)=""
. W:AGWM !,"< 'Non-Indian' Ben/Class requires 'Non-Indian' Tribe >"
G ELIG
;****************************************************************
ELIG ;Check Eligibility
I AGEL']"" D
. S AG("ER",9)=""
. W:AGWM !,"< Eligibility Missing >"
I ((AGB=1)!(AGB=3)!(AGB=4)),AGEL="I" D
. S AG("ER",9)=""
. W:AGWM !,"< Ben/Class selected should be Eligible for care >"
TRBQT ;
;Check Tribe and Indian Quantum consistency
;I AGT=990,("NONE")[AGQI Q ;IHS/SD/TPF H5933
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" W:AGWM !,"< WARNING ... Valid Tribe should be Eligible for Care >",*7
S AGQF=0
I "UNKNOWN,NONE"'[AGQI S AGQF=1
I AGTF=AGQF
E D
. S AG("ER",9)=""
. W:AGWM !,"< Tribe Selected and Indian Quantum are Inconsistent >"
QTCHK ;
;Check Quantums consistency
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 AG("ER",9)=""
. W:AGWM !,"< Quantums are Inconsistent >"
END ;
EXIT ;return to calling program
K AGT,AG11,AGB,AGEL,AGWM,AGTF,AGQF
Q
AGELCHK ; IHS/ASDS/EFG - TRIBE-QUANTUM-BEN CODE CONSISTENCY CHECKER ;
+1 ;;7.1;PATIENT REGISTRATION;**4,5**;AUG 25,2005
+2 ;
+3 ; ****************************************************************
+4 ; This will return AG("ER",9)="" if the entry is inconsistant
+5 ; If AGWM is set=1 then messages will be writen out
+6 ; DFN is required
+7 ; ****************************************************************
+8 ;
SET ;
+1 IF '$DATA(AGWM)
SET AGWM=0
+2 ;AGWM is to be set prior if Writing Messages is desired
+3 KILL AG("ER",9)
+4 IF $DATA(^AUPNPAT(DFN,11))
Begin DoDot:1
+5 SET AG11=^AUPNPAT(DFN,11)
+6 ;CLASS/BENEFICIARY
SET AGB=$PIECE(AG11,U,11)
+7 ;TRIBE OF MEMBERSHIP
SET AGTP=$PIECE(AG11,U,8)
+8 ;TRIBE QUANTUM
SET AGQT=$PIECE(AG11,U,9)
+9 ;INDIAN BLOOD QUANTUM
SET AGQI=$PIECE(AG11,U,10)
+10 ;ELIGIBILITY STATUS
SET AGEL=$PIECE(AG11,U,12)
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET AG("ER",9)=""
+13 IF AGWM
WRITE !,"< Missing Eligibility, Beneficiary, Tribal Information >"
End DoDot:1
GOTO EXIT
S ;
TRIBE ;
+1 ;I $L(AGTP),$D(^AUTTTRI(AGTP,0)),$P(^(0),U,4)="N" S AGT=$P(^AUTTTRI(AGTP,0),U,2)
+2 ;IHS/SD/TPF AG*7.1*4 IM23957
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)
+3 IF '$TEST
Begin DoDot:1
+4 SET AG("ER",9)=""
+5 SET AGT=0
+6 IF AGWM
WRITE !,"<< INVALID old TRIBE >>"
End DoDot:1
GOTO ELIG
+7 SET AGT=+AGT
+8 SET AGB=+AGB
+9 ;BEN = Indian
IF +AGB=1
GOTO IND
+10 FOR I=6,18,32,33,8
IF +AGB=I
GOTO NON
+11 ;all other BEN and tribe combinations are acceptable
+12 GOTO ELIG
+13 ;****************************************************************
IND ;check BEN=1 TR'=000,970
+1 IF AGT>0
IF AGT'=970
GOTO ELIG
+2 IF '$TEST
Begin DoDot:1
+3 SET AG("ER",9)=""
+4 IF AGWM
WRITE !,"<< Native American requires Valid Indian Tribe >>"
End DoDot:1
+5 GOTO ELIG
+6 ;****************************************************************
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 AG("ER",9)=""
+4 IF AGWM
WRITE !,"< 'OTHER' Ben/Class requires 'Non-Indian' or 'Unspecified' Tribe >"
End DoDot:1
GOTO ELIG
+5 IF ((AGT=0)!(AGT=970))
GOTO ELIG
+6 IF '$TEST
Begin DoDot:1
+7 ;I AGT=990 Q ;IHS/SD/TPF H5933
+8 SET AG("ER",9)=""
+9 IF AGWM
WRITE !,"< 'Non-Indian' Ben/Class requires 'Non-Indian' Tribe >"
End DoDot:1
+10 GOTO ELIG
+11 ;****************************************************************
ELIG ;Check Eligibility
+1 IF AGEL']""
Begin DoDot:1
+2 SET AG("ER",9)=""
+3 IF AGWM
WRITE !,"< Eligibility Missing >"
End DoDot:1
+4 IF ((AGB=1)!(AGB=3)!(AGB=4))
IF AGEL="I"
Begin DoDot:1
+5 SET AG("ER",9)=""
+6 IF AGWM
WRITE !,"< Ben/Class selected should be Eligible for care >"
End DoDot:1
TRBQT ;
+1 ;Check Tribe and Indian Quantum consistency
+2 ;I AGT=990,("NONE")[AGQI Q ;IHS/SD/TPF H5933
+3 SET AGTF=1
+4 IF ((AGT=0)!(AGT=970))
SET AGTF=0
+5 IF AGT=999
FOR AGZ=6,8,18,32,33
IF AGB=AGZ
SET AGTF=0
+6 IF AGTF
IF AGEL="I"
IF AGWM
WRITE !,"< WARNING ... Valid Tribe should be Eligible for Care >",*7
+7 SET AGQF=0
+8 IF "UNKNOWN,NONE"'[AGQI
SET AGQF=1
+9 IF AGTF=AGQF
+10 IF '$TEST
Begin DoDot:1
+11 SET AG("ER",9)=""
+12 IF AGWM
WRITE !,"< Tribe Selected and Indian Quantum are Inconsistent >"
End DoDot:1
QTCHK ;
+1 ;Check Quantums consistency
+2 IF '$GET(AGSITE)
IF '$DATA(^AGFAC(DUZ(2)))
QUIT
+3 IF $GET(AGSITE)
IF '$DATA(^AGFAC(AGSITE))
QUIT
+4 IF $PIECE(^AGFAC($SELECT($DATA(AGSITE):AGSITE,1:DUZ(2)),0),"^",2)'="Y"
GOTO END
+5 IF AGQT=AGQI
GOTO END
+6 IF "UNKNOWN,NONE"'[AGQI
IF "UNKNOWN,NONE"'[AGQT
+7 IF '$TEST
Begin DoDot:1
+8 SET AG("ER",9)=""
+9 IF AGWM
WRITE !,"< Quantums are Inconsistent >"
End DoDot:1
END ;
EXIT ;return to calling program
+1 KILL AGT,AG11,AGB,AGEL,AGWM,AGTF,AGQF
+2 QUIT
