AGGWVAL1 ;VNGT/HS/ALA-Validation continued ; 05 Nov 2010 10:41 AM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
;
TBQ(X,DFN,IBQ,AGGPTCLB) ;EP - Tribal Blood Quantum
N RTN,CLBEN
;
;Skip check if classification/beneficiary is not Indian/Alaskan Native
S CLBEN=$O(^AUTTBEN("B","INDIAN/ALASKA NATIVE","")) ;Get Classification IEN
I AGGPTCLB]"",AGGPTCLB'=CLBEN S RESULT=1,MSG="" Q
;
D
. I $L(IBQ)>11!($L(IBQ)<1) K IBQ Q
. I "NF"[$E(IBQ) S IBQ=$S($E(IBQ)="F":"FULL",1:"NONE") Q
. I $E(IBQ)'?1N&(($E(IBQ,1,3)'="UNK")&($E(IBQ,1,3)'="UNS")) K IBQ Q
. I $E(IBQ)="U" S IBQ=$S($E(IBQ,3)="K":"UNKNOWN",1:"UNSPECIFIED") Q
. I IBQ'?1.4N1"/"1.5N K IBQ Q
. I $P(IBQ,"/",1)>$P(IBQ,"/",2)!(+$P(IBQ,"/",2)=0) K IBQ Q
. S:$P(IBQ,"/",1)=$P(IBQ,"/",2) IBQ="FULL" Q
D
. I $L(X)>11!($L(X)<1) K X Q
. I "NF"[$E(X) S X=$S($E(X)="F":"FULL",1:"NONE") Q
. I $E(X)'?1N&(($E(X,1,3)'="UNK")&($E(X,1,3)'="UNS")) K X Q
. I $E(X)="U" S X=$S($E(X,3)="K":"UNKNOWN",1:"UNSPECIFIED") Q
. I X'?1.4N1"/"1.5N K X Q
. I $P(X,"/",1)>$P(X,"/",2)!(+$P(X,"/",2)=0) K X Q
. S:$P(X,"/",1)=$P(X,"/",2) X="FULL" Q
;
S RESULT=1
;
I $G(X)="" S RESULT=-1,MSG="Entry not valid"
I $G(IBQ)="" S RESULT=-1,MSG="Quantums are Inconsistent"
;
;Basic Quantum checks
I RESULT=1,"UNKNOWN,NONE,UNSPECIFIED"[IBQ,"UNKOWN,NONE,UNSPECIFIED"'[X D
. S MSG="Quantums are Inconsistent",RESULT=-1,CODE="AGGPTTRQ"
;
I RESULT=1,X="FULL",IBQ'="FULL" D
. S MSG="Quantums are Inconsistent",RESULT=-1,CODE="AGGPTTRQ"
;
;Check to see if main tribal quantum is greater than blood quantum
I RESULT=1,$P($G(^AGFAC(DUZ(2),0)),U,2)="Y" S RTN=$$QUANT^AGGUL2(IBQ,X,0) I $P(RTN,U)=-1 S MSG="The Tribal Quantum cannot be greater than the Indian Blood Quantum",RESULT=-1
;
;Set up fields to revalidate
S REVAL="AGGPTELG;AGGPTCLB;AGGPTTRI;AGGPTBLQ"
Q
;
FEMP(AGGFTEMN,AGGFTNME,AGGMTEMN,AGGMTNME,DFN) ; EP = Father's Employer check
S RESULT=1
NEW AGE
S AGE=$$AGE^AGGAGE(DFN)
I AGE'<18 Q
I $G(AGGMTNME)="",$G(AGGFTNME)="" Q
; If father's name exists and father's employer exists, okay
I $$FTH(AGGFTNME,AGGFTEMN) Q
; if mother's name exists and mother's employer exists, okay
I $$MTH(AGGMTNME,AGGMTEMN) Q
; if father's name exists
S REVAL="AGGFTEMN;AGGFTNME;AGGMTEMN;AGGMTNME"
I $G(AGGFTNME)'="" D Q
. ; If mother's name does not exist and father's employer does not exist
. I '$$MTH(AGGMTNME,AGGMTEMN),$G(AGGFTEMN)="" S RESULT=-1,MSG="Father's Employer must be entered." Q
; If neither is true, error
I '$$MTH(AGGMTNME,AGGMTEMN),'$$FTH(AGGFTNME,AGGFTEMN) D
. I $G(AGGFTNME)="",$G(AGGMTNME)'="" Q
. S RESULT=-1,MSG="Mother or Father's Employer must be entered." Q
Q
;
MEMP(AGGMTEMN,AGGMTNME,AGGFTNME,AGGFTEMN,DFN) ; EP = Mother's Employer check
S RESULT=1
NEW AGE
S AGE=$$AGE^AGGAGE(DFN)
I AGE'<18 Q
I $G(AGGMTNME)="",$G(AGGFTNME)="" Q
; if mother's name exists and mother's employer exists, okay
I $$MTH(AGGMTNME,AGGMTEMN) Q
; If father's name exists and father's employer exists, okay
I $$FTH(AGGFTNME,AGGFTEMN) Q
; if mother's name exists
S REVAL="AGGMTEMN;AGGMTNME;AGGFTNME;AGGFTEMN"
I $G(AGGMTNME)'="" D Q
. I '$$FTH(AGGFTNME,AGGFTEMN),$G(AGGMTEMN)="" S RESULT=-1,MSG="Mother's Employer must be entered." Q
; If neither is true, error
I '$$MTH(AGGMTNME,AGGMTEMN),'$$FTH(AGGFTNME,AGGFTEMN) D
. I $G(AGGMTNME)="",$G(AGGFTNME)'="" Q
. S RESULT=-1,MSG="Mother or Father's Employer must be entered." Q
Q
;
FTH(AGGFTNME,AGGFTEMN) ; EP
I $G(AGGFTNME)="",$G(AGGFTEMN)="" Q 0
I $G(AGGFTNME)'="",$G(AGGFTEMN)'="" Q 1
Q 0
;
MTH(AGGMTNME,AGGMTEMN) ; EP
I $G(AGGMTNME)="",$G(AGGMTEMN)="" Q 0
I $G(AGGMTNME)'="",$G(AGGMTEMN)'="" Q 1
Q 0
AGGWVAL1 ;VNGT/HS/ALA-Validation continued ; 05 Nov 2010 10:41 AM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
+3 ;
TBQ(X,DFN,IBQ,AGGPTCLB) ;EP - Tribal Blood Quantum
+1 NEW RTN,CLBEN
+2 ;
+3 ;Skip check if classification/beneficiary is not Indian/Alaskan Native
+4 ;Get Classification IEN
SET CLBEN=$ORDER(^AUTTBEN("B","INDIAN/ALASKA NATIVE",""))
+5 IF AGGPTCLB]""
IF AGGPTCLB'=CLBEN
SET RESULT=1
SET MSG=""
QUIT
+6 ;
+7 Begin DoDot:1
+8 IF $LENGTH(IBQ)>11!($LENGTH(IBQ)<1)
KILL IBQ
QUIT
+9 IF "NF"[$EXTRACT(IBQ)
SET IBQ=$SELECT($EXTRACT(IBQ)="F":"FULL",1:"NONE")
QUIT
+10 IF $EXTRACT(IBQ)'?1N&(($EXTRACT(IBQ,1,3)'="UNK")&($EXTRACT(IBQ,1,3)'="UNS"))
KILL IBQ
QUIT
+11 IF $EXTRACT(IBQ)="U"
SET IBQ=$SELECT($EXTRACT(IBQ,3)="K":"UNKNOWN",1:"UNSPECIFIED")
QUIT
+12 IF IBQ'?1.4N1"/"1.5N
KILL IBQ
QUIT
+13 IF $PIECE(IBQ,"/",1)>$PIECE(IBQ,"/",2)!(+$PIECE(IBQ,"/",2)=0)
KILL IBQ
QUIT
+14 IF $PIECE(IBQ,"/",1)=$PIECE(IBQ,"/",2)
SET IBQ="FULL"
QUIT
End DoDot:1
+15 Begin DoDot:1
+16 IF $LENGTH(X)>11!($LENGTH(X)<1)
KILL X
QUIT
+17 IF "NF"[$EXTRACT(X)
SET X=$SELECT($EXTRACT(X)="F":"FULL",1:"NONE")
QUIT
+18 IF $EXTRACT(X)'?1N&(($EXTRACT(X,1,3)'="UNK")&($EXTRACT(X,1,3)'="UNS"))
KILL X
QUIT
+19 IF $EXTRACT(X)="U"
SET X=$SELECT($EXTRACT(X,3)="K":"UNKNOWN",1:"UNSPECIFIED")
QUIT
+20 IF X'?1.4N1"/"1.5N
KILL X
QUIT
+21 IF $PIECE(X,"/",1)>$PIECE(X,"/",2)!(+$PIECE(X,"/",2)=0)
KILL X
QUIT
+22 IF $PIECE(X,"/",1)=$PIECE(X,"/",2)
SET X="FULL"
QUIT
End DoDot:1
+23 ;
+24 SET RESULT=1
+25 ;
+26 IF $GET(X)=""
SET RESULT=-1
SET MSG="Entry not valid"
+27 IF $GET(IBQ)=""
SET RESULT=-1
SET MSG="Quantums are Inconsistent"
+28 ;
+29 ;Basic Quantum checks
+30 IF RESULT=1
IF "UNKNOWN,NONE,UNSPECIFIED"[IBQ
IF "UNKOWN,NONE,UNSPECIFIED"'[X
Begin DoDot:1
+31 SET MSG="Quantums are Inconsistent"
SET RESULT=-1
SET CODE="AGGPTTRQ"
End DoDot:1
+32 ;
+33 IF RESULT=1
IF X="FULL"
IF IBQ'="FULL"
Begin DoDot:1
+34 SET MSG="Quantums are Inconsistent"
SET RESULT=-1
SET CODE="AGGPTTRQ"
End DoDot:1
+35 ;
+36 ;Check to see if main tribal quantum is greater than blood quantum
+37 IF RESULT=1
IF $PIECE($GET(^AGFAC(DUZ(2),0)),U,2)="Y"
SET RTN=$$QUANT^AGGUL2(IBQ,X,0)
IF $PIECE(RTN,U)=-1
SET MSG="The Tribal Quantum cannot be greater than the Indian Blood Quantum"
SET RESULT=-1
+38 ;
+39 ;Set up fields to revalidate
+40 SET REVAL="AGGPTELG;AGGPTCLB;AGGPTTRI;AGGPTBLQ"
+41 QUIT
+42 ;
FEMP(AGGFTEMN,AGGFTNME,AGGMTEMN,AGGMTNME,DFN) ; EP = Father's Employer check
+1 SET RESULT=1
+2 NEW AGE
+3 SET AGE=$$AGE^AGGAGE(DFN)
+4 IF AGE'<18
QUIT
+5 IF $GET(AGGMTNME)=""
IF $GET(AGGFTNME)=""
QUIT
+6 ; If father's name exists and father's employer exists, okay
+7 IF $$FTH(AGGFTNME,AGGFTEMN)
QUIT
+8 ; if mother's name exists and mother's employer exists, okay
+9 IF $$MTH(AGGMTNME,AGGMTEMN)
QUIT
+10 ; if father's name exists
+11 SET REVAL="AGGFTEMN;AGGFTNME;AGGMTEMN;AGGMTNME"
+12 IF $GET(AGGFTNME)'=""
Begin DoDot:1
+13 ; If mother's name does not exist and father's employer does not exist
+14 IF '$$MTH(AGGMTNME,AGGMTEMN)
IF $GET(AGGFTEMN)=""
SET RESULT=-1
SET MSG="Father's Employer must be entered."
QUIT
End DoDot:1
QUIT
+15 ; If neither is true, error
+16 IF '$$MTH(AGGMTNME,AGGMTEMN)
IF '$$FTH(AGGFTNME,AGGFTEMN)
Begin DoDot:1
+17 IF $GET(AGGFTNME)=""
IF $GET(AGGMTNME)'=""
QUIT
+18 SET RESULT=-1
SET MSG="Mother or Father's Employer must be entered."
QUIT
End DoDot:1
+19 QUIT
+20 ;
MEMP(AGGMTEMN,AGGMTNME,AGGFTNME,AGGFTEMN,DFN) ; EP = Mother's Employer check
+1 SET RESULT=1
+2 NEW AGE
+3 SET AGE=$$AGE^AGGAGE(DFN)
+4 IF AGE'<18
QUIT
+5 IF $GET(AGGMTNME)=""
IF $GET(AGGFTNME)=""
QUIT
+6 ; if mother's name exists and mother's employer exists, okay
+7 IF $$MTH(AGGMTNME,AGGMTEMN)
QUIT
+8 ; If father's name exists and father's employer exists, okay
+9 IF $$FTH(AGGFTNME,AGGFTEMN)
QUIT
+10 ; if mother's name exists
+11 SET REVAL="AGGMTEMN;AGGMTNME;AGGFTNME;AGGFTEMN"
+12 IF $GET(AGGMTNME)'=""
Begin DoDot:1
+13 IF '$$FTH(AGGFTNME,AGGFTEMN)
IF $GET(AGGMTEMN)=""
SET RESULT=-1
SET MSG="Mother's Employer must be entered."
QUIT
End DoDot:1
QUIT
+14 ; If neither is true, error
+15 IF '$$MTH(AGGMTNME,AGGMTEMN)
IF '$$FTH(AGGFTNME,AGGFTEMN)
Begin DoDot:1
+16 IF $GET(AGGMTNME)=""
IF $GET(AGGFTNME)'=""
QUIT
+17 SET RESULT=-1
SET MSG="Mother or Father's Employer must be entered."
QUIT
End DoDot:1
+18 QUIT
+19 ;
FTH(AGGFTNME,AGGFTEMN) ; EP
+1 IF $GET(AGGFTNME)=""
IF $GET(AGGFTEMN)=""
QUIT 0
+2 IF $GET(AGGFTNME)'=""
IF $GET(AGGFTEMN)'=""
QUIT 1
+3 QUIT 0
+4 ;
MTH(AGGMTNME,AGGMTEMN) ; EP
+1 IF $GET(AGGMTNME)=""
IF $GET(AGGMTEMN)=""
QUIT 0
+2 IF $GET(AGGMTNME)'=""
IF $GET(AGGMTEMN)'=""
QUIT 1
+3 QUIT 0
