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
