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

BQIPTFHD.m

Go to the documentation of this file. 
  1. BQIPTFHD ;VNGT/HS/ALA-Family History Detail ; 12 Sep 2008  12:30 PM
  1.  ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
  1.  ;
  1.  Q
  1.  ;
  1. EN(DATA,DFN) ; EP -- BQI PAT FAM HISTORY DETAIL
  1.  ;
  1.  ;Description - all the family history that a patient has
  1.  ;
  1.  ;Input Parameters
  1.  ;  DFN - Patient internal entry number
  1.  ;Parameters
  1.  ;  
  1.  NEW UID,II,IEN,DIAG,NARR,RELAT,AGE,STAT,DTMNT,PROV,RELN,RELT,STC,STT,PRVR,PRVN,NIEN
  1.  NEW ARRAY,CIEN,RIEN,AGC,FHXDTLM,RORD,ORD,PROV,AGDTH,AGEDT,CASDTH,DIEN,FLD,MLTB,MLTBT
  1.  NEW MULT,MULTYP,NARRT,PRV,RELD,RELNM,FAM
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTFHD",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S @DATA@(II)="I00010FHXIEN^I00010FHXRIEN^T00060FHXRLTN^T00030FHXREL^T00060FHXDXN^T00080DXNARR^"
  1.  S @DATA@(II)=@DATA@(II)_"T00020FHXAGE^T00020FHXSTAT^D00030FHXDTNT^T00100APCDTNQ^T00050FHXPROV^"
  1.  S @DATA@(II)=@DATA@(II)_"T00015FHXAAD^T00060FHXCDTH^T00010FHXMBRTH^T00020FHXMBTY^D00015FHXDTLM"_$C(30)
  1.  S CIEN=""
  1.  F  S CIEN=$O(^AUPNFH("AC",DFN,CIEN)) Q:CIEN=""  D
  1.  . S DTMNT=$$GET1^DIQ(9000014,CIEN_",",.03,"I")
  1.  . S DIEN=$$GET1^DIQ(9000014,CIEN_",",.01,"I") I DIEN="" Q
  1.  . I $$VERSION^XPDUTL("BCSV") S DIAG=$$ICD9^BQIUL3(DIEN,DTMNT,2)_"-"_$$ICD9^BQIUL3(DIEN,DTMNT,4) ; csv
  1.  . I '$$VERSION^XPDUTL("BCSV") S DIAG=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")
  1.  . S DIAG=DIEN_$C(28)_DIAG
  1.  . S NARR=$$GET1^DIQ(9000014,CIEN_",",.04,"E")
  1.  . S NIEN=$$GET1^DIQ(9000014,CIEN_",",.04,"I")
  1.  . I $$PATCH^XPDUTL("BJPC*2.0*10") S NARR=$$PNPROB^AUPNVUTL(NIEN)
  1.  . S NARRT="" I NIEN'="" S NARRT=NIEN_$C(28)_NARR
  1.  . S FLD=.11,AGC=$$GET1^DIQ(9000014,CIEN_",",FLD,"I")
  1.  . I AGC=FLD S AGC=""
  1.  . S AGE="" I AGC'="" S AGE=AGC_$C(28)_$$GET1^DIQ(9000014,CIEN_",",.11,"E")
  1.  . S FLD=.09,RIEN=$$GET1^DIQ(9000014,CIEN_",",.09,"I")
  1.  . I RIEN=FLD S RIEN=""
  1.  . I RIEN'="" S FAM(RIEN)=""
  1.  . D GFAM
  1.  . S PRV=$$GET1^DIQ(9000014,CIEN_",",.08,"I")
  1.  . S PROV="" I PRV'="" S PROV=PRV_$C(28)_$$GET1^DIQ(9000014,CIEN_",",.08,"E")
  1.  . S ARRAY(RORD,RELNM,CIEN)=CIEN_U_RIEN_U_RELAT_U_RELD_U_DIAG_U_NARR_U_AGE_U_STAT_U_$$FMTE^BQIUL1(DTMNT)_U_NARRT_U_PROV_U_AGEDT_U_CASDTH_U_MULT_U_MULTYP_U_$$FMTE^BQIUL1(FHXDTLM)_$C(30)
  1.  . ;
  1.  S CIEN=""
  1.  F  S CIEN=$O(^AUPNFHR("AA",DFN,CIEN)) Q:'CIEN  S RIEN="" D
  1.  . F  S RIEN=$O(^AUPNFHR("AA",DFN,CIEN,RIEN)) Q:RIEN=""  D
  1.  .. I $D(FAM(RIEN)) Q
  1.  .. ; For family without diagnoses search FAMILY HISTORY FAMILY MEMBERS file
  1.  .. D GFAM
  1.  .. S ARRAY(RORD,RELNM,"R"_RIEN)=U_RIEN_U_RELAT_U_RELD_U_U_U_U_STAT_U_U_U_U_AGEDT_U_CASDTH_U_MULT_U_MULTYP_U_$$FMTE^BQIUL1(FHXDTLM)_$C(30)
  1.  S ORD=""
  1.  F  S ORD=$O(ARRAY(ORD)) Q:ORD=""  D
  1.  . S RELNM=""
  1.  . F  S RELNM=$O(ARRAY(ORD,RELNM)) Q:RELNM=""  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(ARRAY(ORD,RELNM,IEN)) Q:IEN=""  D
  1.  ... S II=II+1,@DATA@(II)=ARRAY(ORD,RELNM,IEN)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. GFAM ; Get family history family members data
  1.  S RELN=$$GET1^DIQ(9000014.1,RIEN_",",.01,"I")
  1.  S RORD=$$GET1^DIQ(9999999.36,RELN_",",2103,"E") S:RORD="" RORD="~"
  1.  S RELT=$$GET1^DIQ(9000014.1,RIEN_",",.01,"E")
  1.  S RELNM=RELT S:RELNM="" RELNM="~"
  1.  S RELD=$$GET1^DIQ(9000014.1,RIEN_",",.03,"E")
  1.  S RELAT="" I RELN'="" S RELAT=RELN_$C(28)_RELT
  1.  S STC=$$GET1^DIQ(9000014.1,RIEN_",",.04,"I")
  1.  S STAT="" I STC'="" S STAT=STC_$C(28)_$$GET1^DIQ(9000014.1,RIEN_",",.04,"E")
  1.  S FHXDTLM=$$GET1^DIQ(9000014.1,RIEN_",",.09,"I")
  1.  S MLTB=$$GET1^DIQ(9000014.1,RIEN_",",.07,"I")
  1.  S MULT="" I MLTB'="" S MULT=MLTB_$C(28)_$$GET1^DIQ(9000014.1,RIEN_",",.07,"E")
  1.  S AGDTH=$$GET1^DIQ(9000014.1,RIEN_",",.05,"I")
  1.  S AGEDT="" I AGDTH'="" S AGEDT=AGDTH_$C(28)_$$GET1^DIQ(9000014.1,RIEN_",",.05,"E")
  1.  S CASDTH=$$GET1^DIQ(9000014.1,RIEN_",",.06,"E")
  1.  S MLTBT=$$GET1^DIQ(9000014.1,RIEN_",",.08,"I")
  1.  S MULTYP="" I MLTBT'="" S MULTYP=MLTBT_$C(28)_$$GET1^DIQ(9000014.1,RIEN_",",.08,"E")
  1.  Q