- BGOREL ; IHS/MSC/MGH - New family history component ;01-Dec-2014 16:24;DU
- ;;1.1;BGO COMPONENTS;**6,13,14**;Mar 20, 2007;Build 16
- ;---------------------------------------------
- ;Add/edit a relationship and diagnoses for a patient
- ;DFN=Patient IEN [1]
- ;LIST(1)=REL^ Relationship ien [2] ^ Relationship [3] ^ Relationship Desc [4] ^ Status [5] ^ Age at Death [6]
- ;Cause of Death [7] ^ Multiple Birth [8] ^ Multiple Birth Type [9]
- ;LIST(n)=FHX^ Family HS ien [2]^ DX [3] ^ Text [4] ^ DX Age [5] ^ DX Age Approximate [6] ^ concept ct [7] ^ DESC CT [8] ^ MULT ICD [9]
- ;Patch 14 Moved NEW to SET line label
- SET(RET,DFN,INP) ;
- N FDA,LP,NEW,IEN,REL,OLDRIEN,RET2,RELIEN,FIEN,RIEN,DESC,STAT,DAGE,DCAUSE,MB,MBT,RNAME,IENX,INP2,DATA
- S RET2="",NEW=0
- I 'DFN S RET=$$ERR^BGOUTL(1001) Q
- I '$D(^DPT(DFN,0)) S RET=$$ERR^BGOUTL(1001) Q
- S LP="" F S LP=$O(INP(LP)) Q:LP="" D
- .S FAM=INP(LP)
- .I $E(FAM,1,3)="REL" D EREL
- .I $E(FAM,1,3)="FHX" D EFHX
- S RET=RET2
- Q
- EREL ;Add/Edit a relationship
- S (RELIEN,OLDRIEN)=$P(FAM,U,2) ;If blank its a new one
- S RNAME=$P(FAM,U,3)
- S RIEN="",RIEN=$O(^AUTTRLSH("B",RNAME,RIEN))
- I RIEN="" S RET=$$ERR^BGOUTL(1008) Q
- ;Q:RIEN=""
- S NEW=0,FIEN=""
- ;Store new relationship
- I RELIEN="" D
- .S RELIEN="+1",NEW=1
- S FDA=$NA(FDA(9000014.1,RELIEN_","))
- S @FDA@(.01)=RNAME
- S @FDA@(.02)="`"_DFN
- S @FDA@(.03)=$P(FAM,U,4)
- S @FDA@(.04)=$P(FAM,U,5)
- S @FDA@(.05)=$P(FAM,U,6)
- S @FDA@(.06)=$P(FAM,U,7)
- S @FDA@(.07)=$P(FAM,U,8)
- S @FDA@(.08)=$P(FAM,U,9)
- I NEW=1 S @FDA@(.11)="TODAY"
- S @FDA@(.09)="TODAY"
- S RET=$$UPDATE^BGOUTL(.FDA,"E@",.IENX)
- S:$E(RELIEN)="+" RELIEN=$G(IENX(1))
- I +RELIEN D
- .S DATA=$G(^AUPNFHR(RELIEN,0))
- .S RET2=RELIEN_";R"
- E S RET2=RET
- Q
- EFHX ;Add/edit a family history
- I '$D(RELIEN) S RET="Relationship not defined" Q
- I RELIEN="" S RET="Unknown relationship" Q
- I OLDRIEN=""&($P(FAM,U,2)'="") S RET="Cannot add an existing FHX to a new relationship" Q
- S INP2=DFN_"^"_RELIEN_"^"_$P(FAM,U,3)_"^"_$P(FAM,U,4)_"^"_$P(FAM,U,5)_"^"_$P(FAM,U,6)_"^"_$P(FAM,U,2)_"^"_$P(FAM,U,7)_"^"_$P(FAM,U,8)_"^"_$P(FAM,U,9)
- S RET=""
- D SET^BGOFHX(.RET,INP2)
- S FIEN=RET
- S RET2=RET2_"^"_FIEN_";F"
- ;Process event
- D EVT^BGOFHX(RELIEN,FIEN,NEW,DATA)
- Q
- N FREL,IEN,RELDATA,REL,STAT,AGE,MB,MBTYPE,CAUSE
- S FREL="" F S FREL=$O(^AUPNFHR("AA",DFN,FREL)) Q:FREL="" D
- .S IEN="" F S IEN=$O(^AUPNFHR("AA",DFN,FREL,IEN)) Q:IEN="" D
- ..I $D(ARRAY(IEN)) Q ;This relationship already exists
- ..I '$D(ARRAY(IEN)) D
- . . . S RELDATA=$G(^AUPNFHR(IEN,0))
- . . . S X=$P(RELDATA,U,1),REL=$$EXTERNAL^DILFD(9000014.1,.01,"",X)
- . . . S X=$P(RELDATA,U,4),STAT=$$EXTERNAL^DILFD(9000014.1,.04,"",X)
- . . . S X=$P(RELDATA,U,5),AGE=$$EXTERNAL^DILFD(9000014.1,.05,"",X)
- . . . S CAUSE=$P(RELDATA,U,6)
- . . . S X=$P(RELDATA,U,7),MB=$$EXTERNAL^DILFD(9000014.1,.07,"",X)
- . . . S X=$P(RELDATA,U,8),MBTYPE=$$EXTERNAL^DILFD(9000014.1,.08,"",X)
- . . . S X=$P(RELDATA,U,9),MOD=$$FMTDATE^BGOUTL(X)
- . . . S NAME=$P(RELDATA,U,3)
- . . . S CNT=CNT+1
- . . . S @RET@(CNT)=IEN_U_REL_U_STAT_U_AGE_U_CAUSE_U_MB_U_MBTYPE_"^^^^"_MOD_U_NAME_"^"
- Q
- BGOREL ; IHS/MSC/MGH - New family history component ;01-Dec-2014 16:24;DU
- +1 ;;1.1;BGO COMPONENTS;**6,13,14**;Mar 20, 2007;Build 16
- +2 ;---------------------------------------------
- +3 ;Add/edit a relationship and diagnoses for a patient
- +4 ;DFN=Patient IEN [1]
- +5 ;LIST(1)=REL^ Relationship ien [2] ^ Relationship [3] ^ Relationship Desc [4] ^ Status [5] ^ Age at Death [6]
- +6 ;Cause of Death [7] ^ Multiple Birth [8] ^ Multiple Birth Type [9]
- +7 ;LIST(n)=FHX^ Family HS ien [2]^ DX [3] ^ Text [4] ^ DX Age [5] ^ DX Age Approximate [6] ^ concept ct [7] ^ DESC CT [8] ^ MULT ICD [9]
- +8 ;Patch 14 Moved NEW to SET line label
- SET(RET,DFN,INP) ;
- +1 NEW FDA,LP,NEW,IEN,REL,OLDRIEN,RET2,RELIEN,FIEN,RIEN,DESC,STAT,DAGE,DCAUSE,MB,MBT,RNAME,IENX,INP2,DATA
- +2 SET RET2=""
- SET NEW=0
- +3 IF 'DFN
- SET RET=$$ERR^BGOUTL(1001)
- QUIT
- +4 IF '$DATA(^DPT(DFN,0))
- SET RET=$$ERR^BGOUTL(1001)
- QUIT
- +5 SET LP=""
- FOR
- SET LP=$ORDER(INP(LP))
- IF LP=""
- QUIT
- Begin DoDot:1
- +6 SET FAM=INP(LP)
- +7 IF $EXTRACT(FAM,1,3)="REL"
- DO EREL
- +8 IF $EXTRACT(FAM,1,3)="FHX"
- DO EFHX
- End DoDot:1
- +9 SET RET=RET2
- +10 QUIT
- EREL ;Add/Edit a relationship
- +1 ;If blank its a new one
- SET (RELIEN,OLDRIEN)=$PIECE(FAM,U,2)
- +2 SET RNAME=$PIECE(FAM,U,3)
- +3 SET RIEN=""
- SET RIEN=$ORDER(^AUTTRLSH("B",RNAME,RIEN))
- +4 IF RIEN=""
- SET RET=$$ERR^BGOUTL(1008)
- QUIT
- +5 ;Q:RIEN=""
- +6 SET NEW=0
- SET FIEN=""
- +7 ;Store new relationship
- +8 IF RELIEN=""
- Begin DoDot:1
- +9 SET RELIEN="+1"
- SET NEW=1
- End DoDot:1
- +10 SET FDA=$NAME(FDA(9000014.1,RELIEN_","))
- +11 SET @FDA@(.01)=RNAME
- +12 SET @FDA@(.02)="`"_DFN
- +13 SET @FDA@(.03)=$PIECE(FAM,U,4)
- +14 SET @FDA@(.04)=$PIECE(FAM,U,5)
- +15 SET @FDA@(.05)=$PIECE(FAM,U,6)
- +16 SET @FDA@(.06)=$PIECE(FAM,U,7)
- +17 SET @FDA@(.07)=$PIECE(FAM,U,8)
- +18 SET @FDA@(.08)=$PIECE(FAM,U,9)
- +19 IF NEW=1
- SET @FDA@(.11)="TODAY"
- +20 SET @FDA@(.09)="TODAY"
- +21 SET RET=$$UPDATE^BGOUTL(.FDA,"E@",.IENX)
- +22 IF $EXTRACT(RELIEN)="+"
- SET RELIEN=$GET(IENX(1))
- +23 IF +RELIEN
- Begin DoDot:1
- +24 SET DATA=$GET(^AUPNFHR(RELIEN,0))
- +25 SET RET2=RELIEN_";R"
- End DoDot:1
- +26 IF '$TEST
- SET RET2=RET
- +27 QUIT
- EFHX ;Add/edit a family history
- +1 IF '$DATA(RELIEN)
- SET RET="Relationship not defined"
- QUIT
- +2 IF RELIEN=""
- SET RET="Unknown relationship"
- QUIT
- +3 IF OLDRIEN=""&($PIECE(FAM,U,2)'="")
- SET RET="Cannot add an existing FHX to a new relationship"
- QUIT
- +4 SET INP2=DFN_"^"_RELIEN_"^"_$PIECE(FAM,U,3)_"^"_$PIECE(FAM,U,4)_"^"_$PIECE(FAM,U,5)_"^"_$PIECE(FAM,U,6)_"^"_$PIECE(FAM,U,2)_"^"_$PIECE(FAM,U,7)_"^"_$PIECE(FAM,U,8)_"^"_$PIECE(FAM,U,9)
- +5 SET RET=""
- +6 DO SET^BGOFHX(.RET,INP2)
- +7 SET FIEN=RET
- +8 SET RET2=RET2_"^"_FIEN_";F"
- +9 ;Process event
- +10 DO EVT^BGOFHX(RELIEN,FIEN,NEW,DATA)
- +11 QUIT
- +1 NEW FREL,IEN,RELDATA,REL,STAT,AGE,MB,MBTYPE,CAUSE
- +2 SET FREL=""
- FOR
- SET FREL=$ORDER(^AUPNFHR("AA",DFN,FREL))
- IF FREL=""
- QUIT
- Begin DoDot:1
- +3 SET IEN=""
- FOR
- SET IEN=$ORDER(^AUPNFHR("AA",DFN,FREL,IEN))
- IF IEN=""
- QUIT
- Begin DoDot:2
- +4 ;This relationship already exists
- IF $DATA(ARRAY(IEN))
- QUIT
- +5 IF '$DATA(ARRAY(IEN))
- Begin DoDot:3
- +6 SET RELDATA=$GET(^AUPNFHR(IEN,0))
- +7 SET X=$PIECE(RELDATA,U,1)
- SET REL=$$EXTERNAL^DILFD(9000014.1,.01,"",X)
- +8 SET X=$PIECE(RELDATA,U,4)
- SET STAT=$$EXTERNAL^DILFD(9000014.1,.04,"",X)
- +9 SET X=$PIECE(RELDATA,U,5)
- SET AGE=$$EXTERNAL^DILFD(9000014.1,.05,"",X)
- +10 SET CAUSE=$PIECE(RELDATA,U,6)
- +11 SET X=$PIECE(RELDATA,U,7)
- SET MB=$$EXTERNAL^DILFD(9000014.1,.07,"",X)
- +12 SET X=$PIECE(RELDATA,U,8)
- SET MBTYPE=$$EXTERNAL^DILFD(9000014.1,.08,"",X)
- +13 SET X=$PIECE(RELDATA,U,9)
- SET MOD=$$FMTDATE^BGOUTL(X)
- +14 SET NAME=$PIECE(RELDATA,U,3)
- +15 SET CNT=CNT+1
- +16 SET @RET@(CNT)=IEN_U_REL_U_STAT_U_AGE_U_CAUSE_U_MB_U_MBTYPE_"^^^^"_MOD_U_NAME_"^"
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +17 QUIT
