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

BGOFHX.m

Go to the documentation of this file. 
  1. BGOFHX ; IHS/MSC/MGH - New family history component ;06-Nov-2014 10:21;DU
  1.  ;;1.1;BGO COMPONENTS;**6,13,14**;Mar 20, 2007;Build 16
  1.  ;---------------------------------------------
  1.  ;
  1.  ; Note: The BGOHFX SET RPC now points to SET^BGOREL, which in turn calls SET^BGOFHX
  1.  ;
  1.  ; Add/edit entry family/personal history corresponding to problem entry
  1.  ; INP=Patient IEN [1] ^ Relationship IEN [2] ^ DX [3] ^ Text [4] ^ DX Age [5] ^DX Age Approximate [6]
  1.  ;^FHX IEN [7] ^ CONCEPT CT [8] ^ DESC CT [9] ^ MULT ICD [10]
  1. SET(RET,INP) ;
  1.  N FDA,RIEN,DFN,DMOD,REL,SNODATA,FNUM,EDIT,ICD,ICDX,ICDIEN,FIEN,FNEW,IENX,NEW,DXAGE,DXAGEAPX,CONCT,NARR,IN,OUT,X
  1.  S DFN=$P(INP,U,1),RIEN=$P(INP,U,2),ICD=$P(INP,U,3),FIEN=$P(INP,U,7)
  1.  Q:DFN=""
  1.  Q:RIEN=""
  1.  S CONCT=$P(INP,U,8),DESCT=$P(INP,U,9)
  1.  S (ICD,ICDIEN)=""
  1.  ;IHS/MSC/MGH Changed to use new API
  1.  ;S SNODATA=$$CONC^BSTSAPI(CONCT_"^^^1")
  1.  S SNODATA=$$CONC^AUPNSICD(CONCT_"^^^1")
  1.  S ICD=$P($P(SNODATA,U,5),";",1)
  1.  I ICD="" D
  1.  .;Patch 14 check for which undefined code to use
  1.  .I $$AICD^BGOUTL2 D
  1.  ..S IMP=$$IMP^ICDEX("10D",DT)
  1.  ..I IMP<$$NOW^XLFDT!(IMP=$$NOW^XLFDT) S ICD="ZZZ.999"
  1.  ..I IMP>$$NOW^XLFDT S ICD=".9999"
  1.  .E  S ICD=".9999"
  1.  I $$AICD^BGOUTL2 S ICDIEN=$P($$ICDDX^ICDEX(ICD,DT,"","E"),U,1)
  1.  E   S ICDIEN=$P($$ICDDX^ICDCODE(ICD),U,1)
  1.  I ICDIEN="" S RET=$$ERR^BGOUTL(1092) Q
  1.  S EDIT=0
  1.  S NEW=0
  1.  I FIEN="" D
  1.  .S FNEW=1
  1.  .S FIEN="+1",NEW=1
  1.  S FDA=$NA(FDA(9000014,FIEN_","))
  1.  S @FDA@(.01)=ICD
  1.  I NEW=1 S @FDA@(.02)="`"_DFN
  1.  S @FDA@(.08)="`"_DUZ
  1.  ;S @FDA@(.09)="`"_$P(INP,U,2)
  1.  S @FDA@(.11)="" ; Clear out AGE AT ONSET field
  1.  S @FDA@(.05)=$P(INP,U,5)
  1.  S @FDA@(.15)=$P(INP,U,6)
  1.  I NEW=1 S @FDA@(.03)="TODAY"
  1.  S @FDA@(.12)="TODAY"
  1.  S @FDA@(.13)=$P(INP,U,8)
  1.  S NARR=$P(INP,U,4)
  1.  S @FDA@(.14)=DESCT
  1.  S NARR=NARR_"|"_DESCT
  1.  S RET=$$FNDNARR^BGOUTL2(NARR)
  1.  Q:RET<0
  1.  S NARR=$S(RET:"`"_RET,1:""),RET=""
  1.  S @FDA@(.04)=NARR
  1.  S RET=$$UPDATE^BGOUTL(.FDA,"E@",.IENX)
  1.  S:$E(FIEN)="+" FIEN=$G(IENX(1))
  1.  I RET="" D
  1.  .N DIE,DA,DR,POP
  1.  .S DIE="^AUPNFH(",DA=FIEN,DR=".09////"_$P(INP,U,2) D ^DIE
  1.  .I $D(POP) S RET=$$ERR^BGOUTL(1026)
  1.  .S DATA=$G(^AUPNFH(FIEN,0))
  1.  S RET=FIEN
  1.  I FIEN="" S RET="-1^Unable to store selected code" Q
  1.  ;Remove current multiple ICD codes and then add them back in
  1.  N DA,DIK,IEN,ERR,MULT,SUB,AIEN,ERR,FDA,SUBIEN
  1.  S ERR=""
  1.  S IEN=0 F  S IEN=$O(^AUPNFH(FIEN,11,IEN)) Q:'+IEN  D
  1.  .S ERR=""
  1.  .S DA(1)=FIEN,DA=IEN
  1.  .S DIK="^AUPNFH(DA(1),11,"
  1.  .S:DA ERR=$$DELETE^BGOUTL(DIK,.DA)
  1.  I ERR'="" Q RET_" "_ERR
  1.  S MULT=$P(SNODATA,U,5)
  1.  F Y=2:1:$L(MULT,";") D
  1.  .K IEN2,ERR
  1.  .S ERR=""
  1.  .S SUB=$P(MULT,";",Y)
  1.  .;S SUB=$$ACTIVE(SUB)
  1.  .I $$AICD^BGOUTL2 S SUBIEN=$P($$ICDDX^ICDEX(SUB,DT,"","E"),U,1)
  1.  .E   S SUBIEN=$P($$ICDDX^ICDCODE(SUB),U,1)
  1.  .S AIEN="+1,"_FIEN_","
  1.  .S FDA(9000014.11,AIEN,.01)=SUBIEN
  1.  .D UPDATE^DIE(,"FDA","IEN2","ERR")
  1.  I ERR S RET=RET_U_"Unable to update qualifiers"
  1.  Q
  1.  ;------------------------------------------------------------
  1.  ;Get the family history for a patient
  1.  ;INP=Patient IEN
  1.  ;.RET returned as a list of records in the format
  1.  ;  Relationship IEN [1] Relationship [2] ^ Status [3] ^ Age at Death [4] ^ Cause of Death [5] ^
  1.  ;  Multiple Birth [6] ^ Multiple Birth Type [7] ^ Condition [8] ^ Narrative [9] ^ [10] ^
  1.  ;  Date Modified [11] ^Description [12]  ^Family hx IEN [13]^ Age at DX [14] ^
  1.  ;  Age at DX Approximate [15] ^ Snomed CT [16] ^ Snomed Desc ID [17] ^
  1.  ;  List of Additional ICD codes - ";" delimited [18]
  1. GET(RET,INP) ;
  1.  N X,DFN,NAME,FHIEN,FHX,CNT,REL,RELDATA,STAT,AGE,CAUSE,MB,MBTYPE,DX,NAR,MOD,ARRAY,DXAGE,DXAGEAPX
  1.  N SNOMEDCT,SNODESC,ICD2,ICD2CODE,ICD2LIST,ICD2IEN,SNOTXT,EVNDT
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S DFN=+INP
  1.  I 'DFN S RET=$$ERR^BGOUTL(1001) Q
  1.  S CNT=0,FHIEN=""
  1.  F  S FHIEN=$O(^AUPNFH("AC",DFN,FHIEN)) Q:FHIEN=""  D
  1.  . S FHX=$G(^AUPNFH(FHIEN,0))
  1.  . Q:FHX=""
  1.  . S (REL,STAT,AGE,CAUSE,MB,MBTYPE,DX,NAR,MOD,DXAGE,DXAGEAPX)=""
  1.  . N RELIEN,DXIEN,NARIEN
  1.  . S DXIEN=$P(FHX,U,1),NARIEN=$P(FHX,U,4),RELIEN=$P(FHX,U,9),EVNDT=$P(FHX,U,3)
  1.  . S (NAR,SNOTXT)=""
  1.  . I RELIEN'="" D
  1.  . . S RELDATA=$G(^AUPNFHR(RELIEN,0))
  1.  . . S X=$P(RELDATA,U,1),REL=$$EXTERNAL^DILFD(9000014.1,.01,"",X)
  1.  . . S X=$P(RELDATA,U,4),STAT=$$EXTERNAL^DILFD(9000014.1,.04,"",X)
  1.  . . S X=$P(RELDATA,U,5),AGE=$$EXTERNAL^DILFD(9000014.1,.05,"",X)
  1.  . . S CAUSE=$P(RELDATA,U,6)
  1.  . . S X=$P(RELDATA,U,7),MB=$$EXTERNAL^DILFD(9000014.1,.07,"",X)
  1.  . . S X=$P(RELDATA,U,8),MBTYPE=$$EXTERNAL^DILFD(9000014.1,.08,"",X)
  1.  . . S NAME=$P(RELDATA,U,3)
  1.  . . ;IHS/MSC/MGH changed patch 14 to use correct calls
  1.  . . ;S DX=$P($G(^ICD9(DXIEN,0)),U,1)
  1.  . . I $$AICD^BGOUTL2 D
  1.  . . . S DX=$P($$ICDDX^ICDEX(DXIEN,EVNDT,"","I"),U,2)
  1.  . . E  D
  1.  .. . S DX=$P($$ICDDX^ICDCODE(DXIEN,EVNDT),U,2)
  1.  . . I +NARIEN S NAR=$$GET1^DIQ(9000014,FHIEN,.04)
  1.  . . S X=$P(FHX,U,12),MOD=$$FMTDATE^BGOUTL(X)
  1.  . . S DXAGE=$P(FHX,U,5)
  1.  . . S DXAGEAPX=$P(FHX,U,15)
  1.  . . S SNOMEDCT=$P(FHX,U,13)
  1.  . . S SNODESC=$P(FHX,U,14)
  1.  . . I SNODESC>0 S SNOTXT=$P($$DESC^BSTSAPI(SNODESC_"^^1"),U,2) ; DKA
  1.  . . S ICD2IEN=0,(ICD2LIST,ICD2CODE)=""
  1.  . . F  S ICD2IEN=$O(^AUPNFH(FHIEN,11,ICD2IEN))  Q:'+ICD2IEN  D
  1.  . . . S ICD2=$P($G(^AUPNFH(FHIEN,11,ICD2IEN,0)),U,1)
  1.  . . . ;IHS/MSC/MGH Changed to use correct code
  1.  . . . ;I +ICD2 S ICD2CODE=$P($G(^ICD9(ICD2,0)),U,1)
  1.  . . .I $$AICD^BGOUTL2 D
  1.  . . . .S ICD2CODE=$P($$ICDDX^ICDEX(ICD2,EVNDT,"","I"),U,2)
  1.  . . .E  D
  1.  . . . .S ICD2CODE=$P($$ICDDX^ICDCODE(ICD2,EVNDT),U,2)
  1.  . . .I ICD2CODE'="" D
  1.  . . . .I ICD2LIST="" S ICD2LIST=ICD2CODE
  1.  . . .E  S ICD2LIST=ICD2LIST_";"_ICD2CODE
  1.  . . S CNT=CNT+1
  1.  . . S ARRAY(RELIEN)=""
  1.  . . S @RET@(CNT)=RELIEN_U_REL_U_STAT_U_AGE_U_CAUSE_U_MB_U_MBTYPE_U_DX_U_NAR_U_U_MOD_U_NAME_U_FHIEN_U_DXAGE_U_DXAGEAPX_U_SNOMEDCT_U_SNODESC_U_ICD2LIST_U_SNOTXT
  1.  ;Check for relationships without any DX attached
  1.  D EXTRA^BGOREL(.ARRAY)
  1.  I CNT=0 S @RET@(1)="No family hx"
  1.  Q
  1.  ;------------------------------------------------------------
  1.  ;Delete a family history problem
  1.  ;INP= Relationship IEN [1] ^ Family HX ien [2]
  1. DEL(RET,INP) ;EP
  1.  N RIEN,DFN,FHIEN,ZN,ZP,REL,FIEN
  1.  S RIEN=$P(INP,U,1),FHIEN=$P(INP,U,2)
  1.  ;If no family history IEN is included, the entire relationship will be deleted
  1.  ;else just delete the family history dx
  1.  I FHIEN="" D
  1.  .D DELREL(.RET,RIEN)
  1.  .D EVT(RIEN,"",2,ZN)
  1.  E  D
  1.  .D DELFH(.RET,FHIEN)
  1.  .D EVT(RIEN,FHIEN,2,ZN)
  1.  Q
  1.  ;
  1. DELFH(RET,FHIEN) ;Delete one family history item
  1.  S ZN=$G(^AUPNFH(FHIEN,0)),RET=""
  1.  S DFN=$P(ZN,U,2)
  1.  S RET=$$DELETE^BGOUTL("^AUPNFH(",FHIEN)
  1.  Q
  1. DELREL(RET,RIEN) ;Delete entire relation
  1.  S ZN=$G(^AUPNFHR(RIEN,0)),RET=""
  1.  Q:ZN=""
  1.  S DFN=$P(ZN,U,2)
  1.  ;Find the family history DX's for this patient and this relationship
  1.  S FIEN="" F  S FIEN=$O(^AUPNFH("AC",DFN,FIEN)) Q:FIEN=""  D
  1.  .S ZP=$G(^AUPNFH(FIEN,0))
  1.  .I $P(ZP,U,9)=RIEN D DELFH(.RET,FIEN)
  1.  S RET=$$DELETE^BGOUTL("^AUPNFHR(",RIEN)
  1.  Q
  1.  ; Broadcast a family history event
  1. EVT(RIEN,FHIEN,OPR,X) ;EP
  1.  N DFN,DATA
  1.  S:'$D(X) X=$G(^AUPNFHR(RIEN,0))
  1.  S DFN=$P(X,U,2),DATA=RIEN_U_FHIEN_$G(CIA("UID"))_U_OPR
  1.  D:DFN BRDCAST^CIANBEVT("PCC."_DFN_".FHH",DATA)
  1.  Q
  1. ACTIVE(TYPE) ;Check to make sure the code is active
  1.  N CDATA
  1.  I $$AICD^BGOUTL2 S CDATA=$$ICDDX^ICDEX(TYPE,$$NOW^XLFDT)
  1.  E  S CDATA=$$ICDDX^ICDCODE(TYPE,$$NOW^XLFDT)
  1.  I $P(CDATA,U,10)'=1 S TYPE=".9999"
  1.  Q TYPE