AGGFTVAL ;VNGT/HS/BEE-AGG Family/Tribal/NOK RPC Calls ; 07 Apr 2010 7:05 PM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
QNT(DATA,TTRI,TTRQ,AGGPTTRI,AGGPTTRQ,AGGPTBLQ,AGGPTCLB,OTHTRIB) ;EP -- AGG QUANTUM VALIDATION
;
;Input
; TTRI - New Other Tribe Tribe
; TTRQ - New Other Tribe Quantum
; AGGPTTRI - Tribe of Membership
; AGGPTTRQ - Tribe of Membership Blood Quantum
; AGGPTBLQ - Indian Blood Quantum
; AGGPTCLB - Classification/Beneficiary
; OTHTRIB - Other Tribe Multiple Field Information
;
NEW UID,II,LIST,BN,BQ,RESULT,OTHTOT,CLBEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGFTVAL",UID))
K @DATA
S II=0,MSG=""
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGFTVAL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="I00010RESULT^T00100ERROR"_$C(30)
;
;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 G DONE
;
;Skip check if we are not recording tribal quantums
I $P($G(^AGFAC(DUZ(2),0)),U,2)'="Y" G DONE
;
; Get list of current Other Tribe entries
S OTHTRIB=$G(OTHTRIB,"")
I OTHTRIB="" D
. S LIST="",BN=""
. F S BN=$O(OTHTRIB(BN)) Q:BN="" S LIST=LIST_OTHTRIB(BN)
. K OTHTRIB
. S OTHTRIB=LIST
. K LIST
;
;Parse Parameters to get total Other Tribe Quantum (excluding new value)
S OTHTOT=0
F BQ=1:1:$L(OTHTRIB,$C(28)) D
. N PDATA,NAME,VALUE,BP,BV
. S PDATA=$P(OTHTRIB,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1) Q:NAME'="AGGOTTRQ"
. S VALUE=$P(PDATA,"=",2,99) Q:VALUE=""
. F BP=1:1:$L(VALUE,$C(29)) S BV=$P(VALUE,$C(29),BP) D
.. I BV="FULL"!(BV="F") S BV=1
.. I BV="NONE"!(BV="UNKNOWN")!(BV="UNSPECIFIED") S BV=0
.. I BV["/" D
... N BV1,BV2
... S BV1=$P(BV,"/")
... S BV2=$P(BV,"/",2) I +BV2=0 S BV=0 Q
... S BV=BV1/BV2
.. S OTHTOT=OTHTOT+(BV)
;
;Add in new Other Tribe Quantum
I TTRQ="FULL"!(TTRQ="F") S TTRQ=1
I TTRQ="NONE"!(TTRQ="UNKNOWN")!(TTRQ="UNSPECIFIED") S TTRQ=0
I TTRQ["/" D
. N T1,T2
. S T1=$P(TTRQ,"/")
. S T2=$P(TTRQ,"/",2) I +T2=0 S TTRQ=0 Q
. S TTRQ=T1/T2
S OTHTOT=OTHTOT+TTRQ
;
;Perform Quantum checks
S RESULT=$$QUANT^AGGUL2(AGGPTBLQ,AGGPTTRQ,OTHTOT)
;
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
DONE ;
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
AGGFTVAL ;VNGT/HS/BEE-AGG Family/Tribal/NOK RPC Calls ; 07 Apr 2010 7:05 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
QNT(DATA,TTRI,TTRQ,AGGPTTRI,AGGPTTRQ,AGGPTBLQ,AGGPTCLB,OTHTRIB) ;EP -- AGG QUANTUM VALIDATION
+1 ;
+2 ;Input
+3 ; TTRI - New Other Tribe Tribe
+4 ; TTRQ - New Other Tribe Quantum
+5 ; AGGPTTRI - Tribe of Membership
+6 ; AGGPTTRQ - Tribe of Membership Blood Quantum
+7 ; AGGPTBLQ - Indian Blood Quantum
+8 ; AGGPTCLB - Classification/Beneficiary
+9 ; OTHTRIB - Other Tribe Multiple Field Information
+10 ;
+11 NEW UID,II,LIST,BN,BQ,RESULT,OTHTOT,CLBEN
+12 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+13 SET DATA=$NAME(^TMP("AGGFTVAL",UID))
+14 KILL @DATA
+15 SET II=0
SET MSG=""
+16 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGFTVAL D UNWIND^%ZTER"
+17 ;
+18 SET @DATA@(II)="I00010RESULT^T00100ERROR"_$CHAR(30)
+19 ;
+20 ;Skip check if classification/beneficiary is not Indian/Alaskan Native
+21 ;Get Classification IEN
SET CLBEN=$ORDER(^AUTTBEN("B","INDIAN/ALASKA NATIVE",""))
+22 IF AGGPTCLB]""
IF AGGPTCLB'=CLBEN
GOTO DONE
+23 ;
+24 ;Skip check if we are not recording tribal quantums
+25 IF $PIECE($GET(^AGFAC(DUZ(2),0)),U,2)'="Y"
GOTO DONE
+26 ;
+27 ; Get list of current Other Tribe entries
+28 SET OTHTRIB=$GET(OTHTRIB,"")
+29 IF OTHTRIB=""
Begin DoDot:1
+30 SET LIST=""
SET BN=""
+31 FOR
SET BN=$ORDER(OTHTRIB(BN))
IF BN=""
QUIT
SET LIST=LIST_OTHTRIB(BN)
+32 KILL OTHTRIB
+33 SET OTHTRIB=LIST
+34 KILL LIST
End DoDot:1
+35 ;
+36 ;Parse Parameters to get total Other Tribe Quantum (excluding new value)
+37 SET OTHTOT=0
+38 FOR BQ=1:1:$LENGTH(OTHTRIB,$CHAR(28))
Begin DoDot:1
+39 NEW PDATA,NAME,VALUE,BP,BV
+40 SET PDATA=$PIECE(OTHTRIB,$CHAR(28),BQ)
IF PDATA=""
QUIT
+41 SET NAME=$PIECE(PDATA,"=",1)
IF NAME'="AGGOTTRQ"
QUIT
+42 SET VALUE=$PIECE(PDATA,"=",2,99)
IF VALUE=""
QUIT
+43 FOR BP=1:1:$LENGTH(VALUE,$CHAR(29))
SET BV=$PIECE(VALUE,$CHAR(29),BP)
Begin DoDot:2
+44 IF BV="FULL"!(BV="F")
SET BV=1
+45 IF BV="NONE"!(BV="UNKNOWN")!(BV="UNSPECIFIED")
SET BV=0
+46 IF BV["/"
Begin DoDot:3
+47 NEW BV1,BV2
+48 SET BV1=$PIECE(BV,"/")
+49 SET BV2=$PIECE(BV,"/",2)
IF +BV2=0
SET BV=0
QUIT
+50 SET BV=BV1/BV2
End DoDot:3
+51 SET OTHTOT=OTHTOT+(BV)
End DoDot:2
End DoDot:1
+52 ;
+53 ;Add in new Other Tribe Quantum
+54 IF TTRQ="FULL"!(TTRQ="F")
SET TTRQ=1
+55 IF TTRQ="NONE"!(TTRQ="UNKNOWN")!(TTRQ="UNSPECIFIED")
SET TTRQ=0
+56 IF TTRQ["/"
Begin DoDot:1
+57 NEW T1,T2
+58 SET T1=$PIECE(TTRQ,"/")
+59 SET T2=$PIECE(TTRQ,"/",2)
IF +T2=0
SET TTRQ=0
QUIT
+60 SET TTRQ=T1/T2
End DoDot:1
+61 SET OTHTOT=OTHTOT+TTRQ
+62 ;
+63 ;Perform Quantum checks
+64 SET RESULT=$$QUANT^AGGUL2(AGGPTBLQ,AGGPTTRQ,OTHTOT)
+65 ;
+66 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+67 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
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
