Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AGGUL2

AGGUL2.m

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