- 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
