AGGUL2 ;VNGT/HS/ALA-Utility Program ; 26 May 2010 12:12 PM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
;
RHI(DFN) ; EP - Restricted Health Information Status
NEW IEN,RESULT,STAT,DATE,OFFICL,TEXT
S RESULT=""
S IEN=$O(^AUPNRHI("B",DFN,""))
I IEN'="" D
. S STAT=$P(^AUPNRHI(IEN,0),U,3)
. S FLD=$S(STAT="P":.11,STAT="A":.21,STAT="R":.41,STAT="N":.31,STAT="E":.52,1:"")
. I FLD="" S DATE=""
. I FLD'="" S DATE=$$FMTE^AGGUL1($$GET1^DIQ(9000039,IEN_",",FLD,"I"))
. S FLD=$S(STAT="A":.22,STAT="R":.42,STAT="N":.32,1:"")
. I FLD="" S OFFICL=""
. I FLD'="" S OFFICL=$$GET1^DIQ(9000039,IEN_",",FLD,"E")
. S TEXT=$$GET1^DIQ(9000039,IEN_",",.02,"E")
. S RESULT=STAT_$C(28)_$$GET1^DIQ(9000039,IEN_",",.03,"E")_U_DATE_U_OFFICL_U_TEXT
Q RESULT
;
ISREQ(FILE,FIELD) ; EP - Is the field required
NEW RETURN,FLDNAM,RGN,RGFN,VAL
I FIELD?.N D FIELD^DID(FILE,FIELD,,"LABEL","RETURN","ERROR") S FLDNAM=RETURN("LABEL")
E S FLDNM=FIELD
S RGN=$O(^AGFAC(DUZ(2),11,"B",FILE,"")) I RGN="" Q
S RGFN=$O(^AGFAC(DUZ(2),11,RGN,1,"B",FLDNM,"")) I RGFN="" Q
S VAL=$P(^AGFAC(DUZ(2),11,RGN,1,RGFN,0),U,2)
Q VAL
;
HRNL(DFN) ;EP - List of HRNs for a patient
NEW HRN,LOC,HDATA,ABR,VAL,ULOC,DVAL
S LOC=0,VAL=""
S DVAL=$$HLK(DUZ(2)),DVAL=$$TKO^AGGUL1(DVAL,"-")
I DVAL'="" S VAL=VAL_DVAL_";"
F S LOC=$O(^AUPNPAT(DFN,41,LOC)) Q:'LOC D
. Q:LOC=DUZ(2)
. S DVAL=$$HLK(LOC),DVAL=$$TKO^AGGUL1(DVAL,"-")
. I DVAL'="" S VAL=VAL_DVAL_";"
Q $$TKO^AGGUL1(VAL,";")
;
HLK(ULOC) ; EP - Get HRN data for a location
NEW HDATA,IACT
S HDATA=$G(^AUPNPAT(DFN,41,ULOC,0))
S HRN=$P(HDATA,U,2),IACT=$P(HDATA,U,3)
I HRN="" Q ""
;S ABR=$P($G(^AUTTLOC(ULOC,1)),U,2)
S ABR=$P(^AUTTLOC(ULOC,0),U,7)
I IACT'="" S HRN="*"_HRN
Q HRN_"-"_ABR
;
COUN(DFN) ;EP - Get the county of the patient's current community
NEW COMM
S COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I") I COMM="" Q ""
Q $$GET1^DIQ(9999999.05,COMM_",",.02,"E")
;
RHH(DFN) ; EP - Header RHI display
NEW VAL
S VAL=$P($$RHI(DFN),U,1)
S VAL=$P(VAL,$C(28),2)
I VAL="APPROVED" S VAL="YES" Q VAL
I VAL="REVOKED" Q VAL
Q ""
;
RHD(DFN) ;EP - Header RHI date
NEW VAL,STAT
S VAL=$$RHI(DFN)
S STAT=$P(VAL,U,1),STAT=$P(STAT,$C(28),2)
;I $P(VAL,U,1)["APPROVED"!($P(VAL,U,1)["REVOKED") S VAL=$P(VAL,U,2) Q VAL
I STAT="APPROVED" S VAL=$P(VAL,U,2) Q VAL
I STAT="REVOKED" S VAL=$P(VAL,U,2) Q VAL
Q ""
;
PVID(IENS,FLD) ;EP - Get effective or expiration date for a policy holder
I $G(IENS)="" Q ""
NEW POLIEN
S POLIEN=$$GET1^DIQ(9000006.11,IENS,.08,"I")
I POLIEN="" Q ""
I FLD=.18,$$GET1^DIQ(9000003.1,POLIEN_",",FLD,"I")>DT Q ""
Q $$FMTE^AGGUL1($$GET1^DIQ(9000003.1,POLIEN_",",FLD,"I"))
;
INS(IENS,COL) ;EP - Get insurance data for column
I $G(IENS)="" Q ""
NEW DATA,INS,II,INN,STATUS,TYP,ST
S INN=$$GET1^DIQ(9000006.11,IENS,.01,"I")
I INN="" Q ""
S II=0,DATA="XX"
D RET^AGGINSUR(INN)
I $G(INS)="" Q ""
I $G(COL)=1 Q $P(INS,U,2)
I $G(COL)=3 Q $P(INS,U,6)
S ST=$P(INS,U,4) I ST'="" S ST=$P(^DIC(5,ST,0),U,2)
Q $P(INS,U,3)_", "_ST_" "_$P(INS,U,5)
;
OTQT(DFN,OTHQTM,MIEN) ;EP - Other Tribe Quantum Total
; DFN - PATIENT IEN
; MIEN - IEN of Other Tribe multiple (if existing record is being updated)
; OTHQTM - other tribe quantum
;
S MIEN=$G(MIEN)
N I,TOT,F1,F2,IBQTM,DAT,TQTM
S TOT=0,I=0
S IBQTM=$$GET1^DIQ(9000001,DFN_",",1110,"E")
S TQTM=$$GET1^DIQ(9000001,DFN_",",1109,"E")
; Pull main tribe quantum value
I TQTM="FULL" S TOT=TOT+1
I TQTM["/" D Q:$G(RESULT)=-1
. S F1=$P(TQTM,"/"),F2=$P(TQTM,"/",2)
. I +F2=0 S RESULT=-1,MSG="Division by zero" Q
. S TOT=TOT+(F1/F2)
;
F S I=$O(^AUPNPAT(DFN,43,I)) Q:I="" D
. I MIEN=I Q ; Don't count information from existing record if it is being updated
. S DAT=$P($G(^AUPNPAT(DFN,43,I,0)),U,2)
. I DAT="FULL" S TOT=TOT+1 Q
. I DAT["/" D Q:$G(RESULT)=-1
.. S F1=$P(DAT,"/"),F2=$P(DAT,"/",2)
.. I +F2=0 S RESULT=-1,MSG="Division by zero" Q
.. S TOT=TOT+(F1/F2)
; add calculation for new quantum
I OTHQTM="FULL" S TOT=TOT+1
I OTHQTM["/" D Q:$G(RESULT)=-1
. S F1=$P(OTHQTM,"/"),F2=$P(OTHQTM,"/",2)
. I +F2=0 S RESULT=-1,MSG="Division by zero" Q
. S TOT=TOT+(F1/F2)
I TOT>1 S RESULT=-1,MSG="Quantum over 100%" Q
I IBQTM["/" D Q:$G(RESULT)=-1
. S F1=$P(IBQTM,"/"),F2=$P(IBQTM,"/",2)
. I +F2=0 S RESULT=-1,MSG="Division by zero" Q
. I TOT>(F1/F2) S RESULT=-1,MSG="Quantum total too large, greater than Indian blood quantum" Q
S RESULT=1
Q
;
QNT ;EP - Check Blood Quantum
; Expects
; DFN - Patient IEN
; IBQ - Indian Blood Quantum
; TBQ - Tribal Blood Quantum
; OTQ - Other Tribe Blood Quantum
;
NEW N1,N2,TOT,TRB,T1,T2,OTOT,OTT,OTQ,O1,O2
;
D
. I IBQ="" S TOT=0 Q
. I IBQ="FULL"!(IBQ="F") S TOT=1 Q
. I IBQ="NONE"!(IBQ="UNKNOWN")!(IBQ="UNSPECIFIED") S TOT=0 Q
. S N1=$P(IBQ,"/",1),N2=$P(IBQ,"/",2)
. S TOT=N1/N2
;
D
. I TBQ="" S TRB=0 Q
. I TBQ="FULL"!(TBQ="F") S TRB=1 Q
. I TBQ="NONE"!(TBQ="UNKNOWN")!(TBQ="UNSPECIFIED") S TRB=0 Q
. S T1=$P(TBQ,"/",1),T2=$P(TBQ,"/",2)
. S TRB=T1/T2
;
S OTOT=0
I $G(OTQ)'="" D
. I OTQ="FULL"!(OTQ="F") S OTOT=1 Q
. I OTQ="NONE"!(OTQ="UNKNOWN")!(OTQ="UNSPECIFIED") S OTOT=0 Q
. S O1=$P(OTQ,"/",1),O2=$P(OTQ,"/",2)
. S OTOT=OTOT+(O1/O2)
;
I $O(^AUPNPAT(DFN,43,0))'="" D
. S OTT=0
. F S OTT=$O(^AUPNPAT(DFN,43,OTT)) Q:'OTT D
.. S OTQ=$P($G(^AUPNPAT(DFN,43,OTT,0)),U,2)
.. I OTQ="" S OTOT=0 Q
.. I OTQ="FULL"!(OTQ="F") S OTOT=1 Q
.. I OTQ="NONE"!(OTQ="UNKNOWN")!(OTQ="UNSPECIFIED") S OTOT=0 Q
.. S O1=$P(OTQ,"/",1),O2=$P(OTQ,"/",2)
.. S OTOT=OTOT+(O1/O2)
I (OTOT+TRB)>TOT S RESULT=-1,MSG="Tribe and Other Tribe Quantums do not add up to Indian Blood Quantum"
S RESULT=1
Q
;
QUANT(AGGPTBLQ,AGGPTTRQ,OTHTOT) ;EP - New Quantum Blood Checks
;
;Input
; AGGPTBLQ - Indian Blood Quantum
; AGGPTTRQ - Tribal Blood Quantum
; OTHTOT - Other Tribe Blood Quantum (Totals including new entry)
;
;Output
; RESULT - PIECE 1 - 1 for success, -1 for failure
; PIECE 2 - ERROR MESSAGE ON FAILURE
;
NEW N1,N2,TOT,TRB,T1,T2,RESULT
;
D
. I AGGPTBLQ="" S TOT=0 Q
. I AGGPTBLQ="FULL"!(AGGPTBLQ="F") S TOT=1 Q
. I AGGPTBLQ="NONE"!(AGGPTBLQ="UNKNOWN")!(AGGPTBLQ="UNSPECIFIED") S TOT=0 Q
. I AGGPTBLQ'["/" S TOT=0 Q
. S N1=$P(AGGPTBLQ,"/",1),N2=$P(AGGPTBLQ,"/",2) I +N2=0 S TOT=0 Q
. S TOT=N1/N2
;
D
. I AGGPTTRQ="" S TRB=0 Q
. I AGGPTTRQ="FULL"!(AGGPTTRQ="F") S TRB=1 Q
. I AGGPTTRQ="NONE"!(AGGPTTRQ="UNKNOWN")!(AGGPTTRQ="UNSPECIFIED") S TRB=0 Q
. I AGGPTTRQ'["/" S TRB=0 Q
. S T1=$P(AGGPTTRQ,"/",1),T2=$P(AGGPTTRQ,"/",2) I +T2=0 S TRB=0 Q
. S TRB=T1/T2
;
I (OTHTOT+TRB)>TOT S RESULT="-1^Sum of Tribe and Other Tribe Quantums is greater than the Indian Blood Quantum" Q RESULT
S RESULT="1^"
Q RESULT
;
ECZP(AGGECZIP) ;EP - Update emergency contact zip code
NEW FIELD,OFLD
S AGGECZIP=$$STRIP^XLFSTR($G(AGGECZIP),"-")
S FIELD=$S($L(AGGECZIP)>5:.2204,1:.338)
S AGGDATAI(2,DFN_",",FIELD)=AGGECZIP
S OFLD=$S(FIELD=.2204:.338,1:.2204)
S AGGDATA(2,DFN_",",OFLD)="@"
Q
;
NKZP(AGGNKZIP) ; EP - Update next of kin zip code
NEW FLD,OFLD
S AGGNKZIP=$$STRIP^XLFSTR($G(AGGNKZIP),"-")
S FLD=$S($L(AGGNKZIP)>5:.2207,1:.218)
S AGGDATAI(2,DFN_",",FLD)=AGGNKZIP
S OFLD=$S(FLD=.2207:.218,1:.2207)
S AGGDATA(2,DFN_",",OFLD)="@"
Q
;
PTZP(AGGPTZIP) ; EP - Update patient zip code
NEW FLD,OFLD
S AGGPTZIP=$$STRIP^XLFSTR($G(AGGPTZIP),"-")
S FLD=$S($L(AGGPTZIP)>5:.1112,1:.116)
S AGGDATAI(2,DFN_",",FLD)=AGGPTZIP
S OFLD=$S(FLD=.1112:.116,1:.1112)
S AGGDATA(2,DFN_",",OFLD)="@"
Q
AGGUL2 ;VNGT/HS/ALA-Utility Program ; 26 May 2010 12:12 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
+3 ;
RHI(DFN) ; EP - Restricted Health Information Status
+1 NEW IEN,RESULT,STAT,DATE,OFFICL,TEXT
+2 SET RESULT=""
+3 SET IEN=$ORDER(^AUPNRHI("B",DFN,""))
+4 IF IEN'=""
Begin DoDot:1
+5 SET STAT=$PIECE(^AUPNRHI(IEN,0),U,3)
+6 SET FLD=$SELECT(STAT="P":.11,STAT="A":.21,STAT="R":.41,STAT="N":.31,STAT="E":.52,1:"")
+7 IF FLD=""
SET DATE=""
+8 IF FLD'=""
SET DATE=$$FMTE^AGGUL1($$GET1^DIQ(9000039,IEN_",",FLD,"I"))
+9 SET FLD=$SELECT(STAT="A":.22,STAT="R":.42,STAT="N":.32,1:"")
+10 IF FLD=""
SET OFFICL=""
+11 IF FLD'=""
SET OFFICL=$$GET1^DIQ(9000039,IEN_",",FLD,"E")
+12 SET TEXT=$$GET1^DIQ(9000039,IEN_",",.02,"E")
+13 SET RESULT=STAT_$CHAR(28)_$$GET1^DIQ(9000039,IEN_",",.03,"E")_U_DATE_U_OFFICL_U_TEXT
End DoDot:1
+14 QUIT RESULT
+15 ;
ISREQ(FILE,FIELD) ; EP - Is the field required
+1 NEW RETURN,FLDNAM,RGN,RGFN,VAL
+2 IF FIELD?.N
DO FIELD^DID(FILE,FIELD,,"LABEL","RETURN","ERROR")
SET FLDNAM=RETURN("LABEL")
+3 IF '$TEST
SET FLDNM=FIELD
+4 SET RGN=$ORDER(^AGFAC(DUZ(2),11,"B",FILE,""))
IF RGN=""
QUIT
+5 SET RGFN=$ORDER(^AGFAC(DUZ(2),11,RGN,1,"B",FLDNM,""))
IF RGFN=""
QUIT
+6 SET VAL=$PIECE(^AGFAC(DUZ(2),11,RGN,1,RGFN,0),U,2)
+7 QUIT VAL
+8 ;
HRNL(DFN) ;EP - List of HRNs for a patient
+1 NEW HRN,LOC,HDATA,ABR,VAL,ULOC,DVAL
+2 SET LOC=0
SET VAL=""
+3 SET DVAL=$$HLK(DUZ(2))
SET DVAL=$$TKO^AGGUL1(DVAL,"-")
+4 IF DVAL'=""
SET VAL=VAL_DVAL_";"
+5 FOR
SET LOC=$ORDER(^AUPNPAT(DFN,41,LOC))
IF 'LOC
QUIT
Begin DoDot:1
+6 IF LOC=DUZ(2)
QUIT
+7 SET DVAL=$$HLK(LOC)
SET DVAL=$$TKO^AGGUL1(DVAL,"-")
+8 IF DVAL'=""
SET VAL=VAL_DVAL_";"
End DoDot:1
+9 QUIT $$TKO^AGGUL1(VAL,";")
+10 ;
HLK(ULOC) ; EP - Get HRN data for a location
+1 NEW HDATA,IACT
+2 SET HDATA=$GET(^AUPNPAT(DFN,41,ULOC,0))
+3 SET HRN=$PIECE(HDATA,U,2)
SET IACT=$PIECE(HDATA,U,3)
+4 IF HRN=""
QUIT ""
+5 ;S ABR=$P($G(^AUTTLOC(ULOC,1)),U,2)
+6 SET ABR=$PIECE(^AUTTLOC(ULOC,0),U,7)
+7 IF IACT'=""
SET HRN="*"_HRN
+8 QUIT HRN_"-"_ABR
+9 ;
COUN(DFN) ;EP - Get the county of the patient's current community
+1 NEW COMM
+2 SET COMM=$$GET1^DIQ(9000001,DFN_",",1117,"I")
IF COMM=""
QUIT ""
+3 QUIT $$GET1^DIQ(9999999.05,COMM_",",.02,"E")
+4 ;
RHH(DFN) ; EP - Header RHI display
+1 NEW VAL
+2 SET VAL=$PIECE($$RHI(DFN),U,1)
+3 SET VAL=$PIECE(VAL,$CHAR(28),2)
+4 IF VAL="APPROVED"
SET VAL="YES"
QUIT VAL
+5 IF VAL="REVOKED"
QUIT VAL
+6 QUIT ""
+7 ;
RHD(DFN) ;EP - Header RHI date
+1 NEW VAL,STAT
+2 SET VAL=$$RHI(DFN)
+3 SET STAT=$PIECE(VAL,U,1)
SET STAT=$PIECE(STAT,$CHAR(28),2)
+4 ;I $P(VAL,U,1)["APPROVED"!($P(VAL,U,1)["REVOKED") S VAL=$P(VAL,U,2) Q VAL
+5 IF STAT="APPROVED"
SET VAL=$PIECE(VAL,U,2)
QUIT VAL
+6 IF STAT="REVOKED"
SET VAL=$PIECE(VAL,U,2)
QUIT VAL
+7 QUIT ""
+8 ;
PVID(IENS,FLD) ;EP - Get effective or expiration date for a policy holder
+1 IF $GET(IENS)=""
QUIT ""
+2 NEW POLIEN
+3 SET POLIEN=$$GET1^DIQ(9000006.11,IENS,.08,"I")
+4 IF POLIEN=""
QUIT ""
+5 IF FLD=.18
IF $$GET1^DIQ(9000003.1,POLIEN_",",FLD,"I")>DT
QUIT ""
+6 QUIT $$FMTE^AGGUL1($$GET1^DIQ(9000003.1,POLIEN_",",FLD,"I"))
+7 ;
INS(IENS,COL) ;EP - Get insurance data for column
+1 IF $GET(IENS)=""
QUIT ""
+2 NEW DATA,INS,II,INN,STATUS,TYP,ST
+3 SET INN=$$GET1^DIQ(9000006.11,IENS,.01,"I")
+4 IF INN=""
QUIT ""
+5 SET II=0
SET DATA="XX"
+6 DO RET^AGGINSUR(INN)
+7 IF $GET(INS)=""
QUIT ""
+8 IF $GET(COL)=1
QUIT $PIECE(INS,U,2)
+9 IF $GET(COL)=3
QUIT $PIECE(INS,U,6)
+10 SET ST=$PIECE(INS,U,4)
IF ST'=""
SET ST=$PIECE(^DIC(5,ST,0),U,2)
+11 QUIT $PIECE(INS,U,3)_", "_ST_" "_$PIECE(INS,U,5)
+12 ;
OTQT(DFN,OTHQTM,MIEN) ;EP - Other Tribe Quantum Total
+1 ; DFN - PATIENT IEN
+2 ; MIEN - IEN of Other Tribe multiple (if existing record is being updated)
+3 ; OTHQTM - other tribe quantum
+4 ;
+5 SET MIEN=$GET(MIEN)
+6 NEW I,TOT,F1,F2,IBQTM,DAT,TQTM
+7 SET TOT=0
SET I=0
+8 SET IBQTM=$$GET1^DIQ(9000001,DFN_",",1110,"E")
+9 SET TQTM=$$GET1^DIQ(9000001,DFN_",",1109,"E")
+10 ; Pull main tribe quantum value
+11 IF TQTM="FULL"
SET TOT=TOT+1
+12 IF TQTM["/"
Begin DoDot:1
+13 SET F1=$PIECE(TQTM,"/")
SET F2=$PIECE(TQTM,"/",2)
+14 IF +F2=0
SET RESULT=-1
SET MSG="Division by zero"
QUIT
+15 SET TOT=TOT+(F1/F2)
End DoDot:1
IF $GET(RESULT)=-1
QUIT
+16 ;
+17 FOR
SET I=$ORDER(^AUPNPAT(DFN,43,I))
IF I=""
QUIT
Begin DoDot:1
+18 ; Don't count information from existing record if it is being updated
IF MIEN=I
QUIT
+19 SET DAT=$PIECE($GET(^AUPNPAT(DFN,43,I,0)),U,2)
+20 IF DAT="FULL"
SET TOT=TOT+1
QUIT
+21 IF DAT["/"
Begin DoDot:2
+22 SET F1=$PIECE(DAT,"/")
SET F2=$PIECE(DAT,"/",2)
+23 IF +F2=0
SET RESULT=-1
SET MSG="Division by zero"
QUIT
+24 SET TOT=TOT+(F1/F2)
End DoDot:2
IF $GET(RESULT)=-1
QUIT
End DoDot:1
+25 ; add calculation for new quantum
+26 IF OTHQTM="FULL"
SET TOT=TOT+1
+27 IF OTHQTM["/"
Begin DoDot:1
+28 SET F1=$PIECE(OTHQTM,"/")
SET F2=$PIECE(OTHQTM,"/",2)
+29 IF +F2=0
SET RESULT=-1
SET MSG="Division by zero"
QUIT
+30 SET TOT=TOT+(F1/F2)
End DoDot:1
IF $GET(RESULT)=-1
QUIT
+31 IF TOT>1
SET RESULT=-1
SET MSG="Quantum over 100%"
QUIT
+32 IF IBQTM["/"
Begin DoDot:1
+33 SET F1=$PIECE(IBQTM,"/")
SET F2=$PIECE(IBQTM,"/",2)
+34 IF +F2=0
SET RESULT=-1
SET MSG="Division by zero"
QUIT
+35 IF TOT>(F1/F2)
SET RESULT=-1
SET MSG="Quantum total too large, greater than Indian blood quantum"
QUIT
End DoDot:1
IF $GET(RESULT)=-1
QUIT
+36 SET RESULT=1
+37 QUIT
+38 ;
QNT ;EP - Check Blood Quantum
+1 ; Expects
+2 ; DFN - Patient IEN
+3 ; IBQ - Indian Blood Quantum
+4 ; TBQ - Tribal Blood Quantum
+5 ; OTQ - Other Tribe Blood Quantum
+6 ;
+7 NEW N1,N2,TOT,TRB,T1,T2,OTOT,OTT,OTQ,O1,O2
+8 ;
+9 Begin DoDot:1
+10 IF IBQ=""
SET TOT=0
QUIT
+11 IF IBQ="FULL"!(IBQ="F")
SET TOT=1
QUIT
+12 IF IBQ="NONE"!(IBQ="UNKNOWN")!(IBQ="UNSPECIFIED")
SET TOT=0
QUIT
+13 SET N1=$PIECE(IBQ,"/",1)
SET N2=$PIECE(IBQ,"/",2)
+14 SET TOT=N1/N2
End DoDot:1
+15 ;
+16 Begin DoDot:1
+17 IF TBQ=""
SET TRB=0
QUIT
+18 IF TBQ="FULL"!(TBQ="F")
SET TRB=1
QUIT
+19 IF TBQ="NONE"!(TBQ="UNKNOWN")!(TBQ="UNSPECIFIED")
SET TRB=0
QUIT
+20 SET T1=$PIECE(TBQ,"/",1)
SET T2=$PIECE(TBQ,"/",2)
+21 SET TRB=T1/T2
End DoDot:1
+22 ;
+23 SET OTOT=0
+24 IF $GET(OTQ)'=""
Begin DoDot:1
+25 IF OTQ="FULL"!(OTQ="F")
SET OTOT=1
QUIT
+26 IF OTQ="NONE"!(OTQ="UNKNOWN")!(OTQ="UNSPECIFIED")
SET OTOT=0
QUIT
+27 SET O1=$PIECE(OTQ,"/",1)
SET O2=$PIECE(OTQ,"/",2)
+28 SET OTOT=OTOT+(O1/O2)
End DoDot:1
+29 ;
+30 IF $ORDER(^AUPNPAT(DFN,43,0))'=""
Begin DoDot:1
+31 SET OTT=0
+32 FOR
SET OTT=$ORDER(^AUPNPAT(DFN,43,OTT))
IF 'OTT
QUIT
Begin DoDot:2
+33 SET OTQ=$PIECE($GET(^AUPNPAT(DFN,43,OTT,0)),U,2)
+34 IF OTQ=""
SET OTOT=0
QUIT
+35 IF OTQ="FULL"!(OTQ="F")
SET OTOT=1
QUIT
+36 IF OTQ="NONE"!(OTQ="UNKNOWN")!(OTQ="UNSPECIFIED")
SET OTOT=0
QUIT
+37 SET O1=$PIECE(OTQ,"/",1)
SET O2=$PIECE(OTQ,"/",2)
+38 SET OTOT=OTOT+(O1/O2)
End DoDot:2
End DoDot:1
+39 IF (OTOT+TRB)>TOT
SET RESULT=-1
SET MSG="Tribe and Other Tribe Quantums do not add up to Indian Blood Quantum"
+40 SET RESULT=1
+41 QUIT
+42 ;
QUANT(AGGPTBLQ,AGGPTTRQ,OTHTOT) ;EP - New Quantum Blood Checks
+1 ;
+2 ;Input
+3 ; AGGPTBLQ - Indian Blood Quantum
+4 ; AGGPTTRQ - Tribal Blood Quantum
+5 ; OTHTOT - Other Tribe Blood Quantum (Totals including new entry)
+6 ;
+7 ;Output
+8 ; RESULT - PIECE 1 - 1 for success, -1 for failure
+9 ; PIECE 2 - ERROR MESSAGE ON FAILURE
+10 ;
+11 NEW N1,N2,TOT,TRB,T1,T2,RESULT
+12 ;
+13 Begin DoDot:1
+14 IF AGGPTBLQ=""
SET TOT=0
QUIT
+15 IF AGGPTBLQ="FULL"!(AGGPTBLQ="F")
SET TOT=1
QUIT
+16 IF AGGPTBLQ="NONE"!(AGGPTBLQ="UNKNOWN")!(AGGPTBLQ="UNSPECIFIED")
SET TOT=0
QUIT
+17 IF AGGPTBLQ'["/"
SET TOT=0
QUIT
+18 SET N1=$PIECE(AGGPTBLQ,"/",1)
SET N2=$PIECE(AGGPTBLQ,"/",2)
IF +N2=0
SET TOT=0
QUIT
+19 SET TOT=N1/N2
End DoDot:1
+20 ;
+21 Begin DoDot:1
+22 IF AGGPTTRQ=""
SET TRB=0
QUIT
+23 IF AGGPTTRQ="FULL"!(AGGPTTRQ="F")
SET TRB=1
QUIT
+24 IF AGGPTTRQ="NONE"!(AGGPTTRQ="UNKNOWN")!(AGGPTTRQ="UNSPECIFIED")
SET TRB=0
QUIT
+25 IF AGGPTTRQ'["/"
SET TRB=0
QUIT
+26 SET T1=$PIECE(AGGPTTRQ,"/",1)
SET T2=$PIECE(AGGPTTRQ,"/",2)
IF +T2=0
SET TRB=0
QUIT
+27 SET TRB=T1/T2
End DoDot:1
+28 ;
+29 IF (OTHTOT+TRB)>TOT
SET RESULT="-1^Sum of Tribe and Other Tribe Quantums is greater than the Indian Blood Quantum"
QUIT RESULT
+30 SET RESULT="1^"
+31 QUIT RESULT
+32 ;
ECZP(AGGECZIP) ;EP - Update emergency contact zip code
+1 NEW FIELD,OFLD
+2 SET AGGECZIP=$$STRIP^XLFSTR($GET(AGGECZIP),"-")
+3 SET FIELD=$SELECT($LENGTH(AGGECZIP)>5:.2204,1:.338)
+4 SET AGGDATAI(2,DFN_",",FIELD)=AGGECZIP
+5 SET OFLD=$SELECT(FIELD=.2204:.338,1:.2204)
+6 SET AGGDATA(2,DFN_",",OFLD)="@"
+7 QUIT
+8 ;
NKZP(AGGNKZIP) ; EP - Update next of kin zip code
+1 NEW FLD,OFLD
+2 SET AGGNKZIP=$$STRIP^XLFSTR($GET(AGGNKZIP),"-")
+3 SET FLD=$SELECT($LENGTH(AGGNKZIP)>5:.2207,1:.218)
+4 SET AGGDATAI(2,DFN_",",FLD)=AGGNKZIP
+5 SET OFLD=$SELECT(FLD=.2207:.218,1:.2207)
+6 SET AGGDATA(2,DFN_",",OFLD)="@"
+7 QUIT
+8 ;
PTZP(AGGPTZIP) ; EP - Update patient zip code
+1 NEW FLD,OFLD
+2 SET AGGPTZIP=$$STRIP^XLFSTR($GET(AGGPTZIP),"-")
+3 SET FLD=$SELECT($LENGTH(AGGPTZIP)>5:.1112,1:.116)
+4 SET AGGDATAI(2,DFN_",",FLD)=AGGPTZIP
+5 SET OFLD=$SELECT(FLD=.1112:.116,1:.1112)
+6 SET AGGDATA(2,DFN_",",OFLD)="@"
+7 QUIT
