AGGWVAL1.m

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