- 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