BQIPTFHS ;APTIV/HC/ALA-Patient Family History ; 02 Jan 2008 12:27 PM
;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
;
Q
;
HIS(DATA,DFN) ; EP -- BQI PATIENT FAMILY HISTORY
;
;Description - all the family history that a patient has
;
;Input
; DFN - Patient internal entry number
;
NEW UID,II,IEN,DIAG,NARR,RELAT,AGE,STAT,DTMNT,PROV,RELN,RELT,STC,STT,PRVR,PRVN,NIEN
NEW ARRAY,CIEN,RIEN,AGC,FHXDTLM,RORD,ORD,FHXRLTN,RELD,RELNM
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTFHS",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHS D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="I00010FHXIEN^I00010FHXRIEN^T00060FHXRLTN^T00060FHXRLDS^T00060FHXDXN^T00080DXNARR^T00020FHXAGE^T00020FHXSTAT^D00030FHXDTNT^T00100APCDTNQ"_$C(30)
I $$VERSION^XPDUTL("BJPC")<2.0 D
. S IEN="",RIEN=""
. F S IEN=$O(^AUPNFH("AC",DFN,IEN)) Q:IEN="" D
.. S DIEN=$$GET1^DIQ(9000014,IEN_",",.01,"I") I DIEN="" Q
.. S DTMNT=$$GET1^DIQ(9000014,IEN_",",.03,"I")
.. I $$VERSION^XPDUTL("BCSV") S DIAG=$$ICD9^BQIUL3(DIEN,DTMNT,2)_"-"_$$ICD9^BQIUL3(DIEN,DTMNT,4) ; csv
.. I '$$VERSION^XPDUTL("BCSV") S DIAG=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")
.. S DIAG=DIEN_$C(28)_DIAG
.. ;S DIAG=$$GET1^DIQ(9000014,IEN_",",.01,"E") I DIAG="" Q
.. S NARR=$$GET1^DIQ(9000014,IEN_",",.04,"E")
.. S NIEN=$$GET1^DIQ(9000014,IEN_",",.04,"I")
.. I $$PATCH^XPDUTL("BJPC*2.0*10") S NARR=$$PNPROB^AUPNVUTL(NIEN)
.. S RELN=$$GET1^DIQ(9000014,IEN_",",.07,"I")
.. S RELT=$$GET1^DIQ(9000014,IEN_",",.07,"E")
.. S RELNM=RELT S:RELNM="" RELNM="~"
.. S RELAT="" I RELN'="" S RELAT=RELN_$C(28)_RELT
.. S AGE=$$GET1^DIQ(9000014,IEN_",",.05,"E")
.. S STC=$$GET1^DIQ(9000014,IEN_",",.06,"I")
.. S STT=$$GET1^DIQ(9000014,IEN_",",.06,"E")
.. S STAT="" I STC'="" S STAT=STC_$C(28)_STT
.. S ARRAY(RELNM,IEN)=IEN_U_U_RELAT_U_U_DIAG_U_NARR_U_AGE_U_STAT_U_$$FMTE^BQIUL1(DTMNT)_U_NIEN_$C(28)_NARR_$C(30)
. S RELNM=""
. F S RELNM=$O(ARRAY(RELNM)) Q:RELNM="" D
.. S IEN=""
.. F S IEN=$O(ARRAY(RELNM,IEN)) Q:IEN="" S II=II+1,@DATA@(II)=ARRAY(RELNM,IEN)
;
I $$VERSION^XPDUTL("BJPC")>1.0 D
. NEW FAM,FREL
. S CIEN=""
. F S CIEN=$O(^AUPNFH("AC",DFN,CIEN)) Q:CIEN="" D
.. S DTMNT=$$GET1^DIQ(9000014,CIEN_",",.12,"I")
.. S DIEN=$$GET1^DIQ(9000014,CIEN_",",.01,"I") I DIEN="" Q
.. I $$VERSION^XPDUTL("BCSV") S DIAG=$$ICD9^BQIUL3(DIEN,DTMNT,2)_"-"_$$ICD9^BQIUL3(DIEN,DTMNT,4) ; csv
.. I '$$VERSION^XPDUTL("BCSV") S DIAG=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")
.. S DIAG=DIEN_$C(28)_DIAG
.. S NARR=$$GET1^DIQ(9000014,CIEN_",",.04,"E")
.. S NIEN=$$GET1^DIQ(9000014,CIEN_",",.04,"I")
.. S AGC=$$GET1^DIQ(9000014,CIEN_",",.11,"I")
.. S AGE="" I AGC'="" S AGE=AGC_$C(28)_$$GET1^DIQ(9000014,CIEN_",",.11,"E")
.. S RIEN=$$GET1^DIQ(9000014,CIEN_",",.09,"I")
.. I RIEN'="" S FAM(RIEN)=""
.. D GFAM
.. S ARRAY(RORD,RELNM,CIEN)=CIEN_U_RIEN_U_RELAT_U_RELD_U_DIAG_U_NARR_U_AGE_U_STAT_U_$$FMTE^BQIUL1(FHXDTLM)_U_NIEN_$C(28)_NARR_$C(30)
. ;
. S CIEN=""
. F S CIEN=$O(^AUPNFHR("AA",DFN,CIEN)) Q:'CIEN S RIEN="" D
.. F S RIEN=$O(^AUPNFHR("AA",DFN,CIEN,RIEN)) Q:RIEN="" D
... I $D(FAM(RIEN)) Q
... ; For family without diagnoses search FAMILY HISTORY FAMILY MEMBERS file
... D GFAM
... S ARRAY(RORD,RELNM,"R"_RIEN)=U_RIEN_U_RELAT_U_RELD_U_U_U_U_STAT_U_$$FMTE^BQIUL1(FHXDTLM)_U_$C(30)
. ;
. S ORD=""
. F S ORD=$O(ARRAY(ORD)) Q:ORD="" D
.. S RELNM=""
.. F S RELNM=$O(ARRAY(ORD,RELNM)) Q:RELNM="" D
... S IEN=""
... F S IEN=$O(ARRAY(ORD,RELNM,IEN)) Q:IEN="" S II=II+1,@DATA@(II)=ARRAY(ORD,RELNM,IEN)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
UPD(DATA,DFN,FHXIEN,FHXDXN,PARMS) ;EP - BQI UPDATE FAMILY HISTORY
;Input
; DFN - Patient internal entry number
; FHXIEN - Family History IEN if null create a new one
; if the FHXIEN is null then FHXDXN (the diagnosis) must be defined
; PARMS - Data values
;
NEW UID,II,VFIEN,FILE,LIST,BN,BQ,PDATA,NAME,VALUE,PFIEN,PTYP,CHIEN,FIELD
NEW BQIDATA,ERROR,RESULT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTFHU",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHS D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T001024ERROR"_$C(30)
;
S FHXIEN=$G(FHXIEN,""),FHXDXN=$G(FHXDXN,"")
I FHXIEN=""&(FHXDXN="") S BMXSEC="RPC Call Failed: Needs diagnosis" Q
;
;if deleting a family history record
I FHXDXN="@" D DEL G DONE
;
S VFIEN=$O(^BQI(90506.3,"B","Family History",""))
I VFIEN="" S BMXSEC="RPC Call Failed: Family History Definition does not exist." Q
S FILE=$P(^BQI(90506.3,VFIEN,0),U,2)
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
I FHXIEN="" D NREC
;
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99) I VALUE="" Q
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
. I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
. ;I PTYP="T" S VALUE=VALUE
. I PTYP="C" D
.. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
. S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
. S BQIDATA(FILE,FHXIEN_",",FIELD)=VALUE
;
K ERROR
I $D(BQIDATA)>0 D FILE^DIE("","BQIDATA","ERROR")
S RESULT=1_U
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
NREC ; Create new record
K DIC,DR,DA
NEW DIC,X,Y
S DIC="^AUPNFH(",DIC(0)="L",X=FHXDXN,DIC("DR")=".02////"_DFN_";.03////^S X=DT;.07////"_$G(FHXRLTN)
K DO,DD D FILE^DICN
S FHXIEN=+Y
Q
;
DEL ; Delete a record
NEW DIK,DA
S RESULT=1_U
S DIK="^AUPNFH("
I FHXIEN'="" S DA=FHXIEN D ^DIK
I FHXIEN="" S RESULT=-1_U_"No Family History record passed in to delete"
S II=II+1,@DATA@(II)=RESULT_$C(30)
Q
;
GFAM ; Get family history family members data
S RELN=$$GET1^DIQ(9000014.1,RIEN_",",.01,"I")
S RORD=$$GET1^DIQ(9999999.36,RELN_",",2103,"E") S:RORD="" RORD="~"
S RELT=$$GET1^DIQ(9000014.1,RIEN_",",.01,"E")
S RELNM=RELT S:RELNM="" RELNM="~"
S RELD=$$GET1^DIQ(9000014.1,RIEN_",",.03,"E")
S RELAT="" I RELN'="" S RELAT=RELN_$C(28)_RELT ;_" "_RELD
S STC=$$GET1^DIQ(9000014.1,RIEN_",",.04,"I")
S STT=$$GET1^DIQ(9000014.1,RIEN_",",.04,"E")
S STAT="" I STC'="" S STAT=STC_$C(28)_STT
S FHXDTLM=$$GET1^DIQ(9000014.1,RIEN_",",.09,"I")
Q
BQIPTFHS ;APTIV/HC/ALA-Patient Family History ; 02 Jan 2008 12:27 PM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
+2 ;
+3 QUIT
+4 ;
HIS(DATA,DFN) ; EP -- BQI PATIENT FAMILY HISTORY
+1 ;
+2 ;Description - all the family history that a patient has
+3 ;
+4 ;Input
+5 ; DFN - Patient internal entry number
+6 ;
+7 NEW UID,II,IEN,DIAG,NARR,RELAT,AGE,STAT,DTMNT,PROV,RELN,RELT,STC,STT,PRVR,PRVN,NIEN
+8 NEW ARRAY,CIEN,RIEN,AGC,FHXDTLM,RORD,ORD,FHXRLTN,RELD,RELNM
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BQIPTFHS",UID))
+11 KILL @DATA
+12 ;
+13 SET II=0
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTFHS D UNWIND^%ZTER"
+15 ;
+16 SET @DATA@(II)="I00010FHXIEN^I00010FHXRIEN^T00060FHXRLTN^T00060FHXRLDS^T00060FHXDXN^T00080DXNARR^T00020FHXAGE^T00020FHXSTAT^D00030FHXDTNT^T00100APCDTNQ"_$CHAR(30)
+17 IF $$VERSION^XPDUTL("BJPC")<2.0
Begin DoDot:1
+18 SET IEN=""
SET RIEN=""
+19 FOR
SET IEN=$ORDER(^AUPNFH("AC",DFN,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+20 SET DIEN=$$GET1^DIQ(9000014,IEN_",",.01,"I")
IF DIEN=""
QUIT
+21 SET DTMNT=$$GET1^DIQ(9000014,IEN_",",.03,"I")
+22 ; csv
IF $$VERSION^XPDUTL("BCSV")
SET DIAG=$$ICD9^BQIUL3(DIEN,DTMNT,2)_"-"_$$ICD9^BQIUL3(DIEN,DTMNT,4)
+23 IF '$$VERSION^XPDUTL("BCSV")
SET DIAG=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")
+24 SET DIAG=DIEN_$CHAR(28)_DIAG
+25 ;S DIAG=$$GET1^DIQ(9000014,IEN_",",.01,"E") I DIAG="" Q
+26 SET NARR=$$GET1^DIQ(9000014,IEN_",",.04,"E")
+27 SET NIEN=$$GET1^DIQ(9000014,IEN_",",.04,"I")
+28 IF $$PATCH^XPDUTL("BJPC*2.0*10")
SET NARR=$$PNPROB^AUPNVUTL(NIEN)
+29 SET RELN=$$GET1^DIQ(9000014,IEN_",",.07,"I")
+30 SET RELT=$$GET1^DIQ(9000014,IEN_",",.07,"E")
+31 SET RELNM=RELT
IF RELNM=""
SET RELNM="~"
+32 SET RELAT=""
IF RELN'=""
SET RELAT=RELN_$CHAR(28)_RELT
+33 SET AGE=$$GET1^DIQ(9000014,IEN_",",.05,"E")
+34 SET STC=$$GET1^DIQ(9000014,IEN_",",.06,"I")
+35 SET STT=$$GET1^DIQ(9000014,IEN_",",.06,"E")
+36 SET STAT=""
IF STC'=""
SET STAT=STC_$CHAR(28)_STT
+37 SET ARRAY(RELNM,IEN)=IEN_U_U_RELAT_U_U_DIAG_U_NARR_U_AGE_U_STAT_U_$$FMTE^BQIUL1(DTMNT)_U_NIEN_$CHAR(28)_NARR_$CHAR(30)
End DoDot:2
+38 SET RELNM=""
+39 FOR
SET RELNM=$ORDER(ARRAY(RELNM))
IF RELNM=""
QUIT
Begin DoDot:2
+40 SET IEN=""
+41 FOR
SET IEN=$ORDER(ARRAY(RELNM,IEN))
IF IEN=""
QUIT
SET II=II+1
SET @DATA@(II)=ARRAY(RELNM,IEN)
End DoDot:2
End DoDot:1
+42 ;
+43 IF $$VERSION^XPDUTL("BJPC")>1.0
Begin DoDot:1
+44 NEW FAM,FREL
+45 SET CIEN=""
+46 FOR
SET CIEN=$ORDER(^AUPNFH("AC",DFN,CIEN))
IF CIEN=""
QUIT
Begin DoDot:2
+47 SET DTMNT=$$GET1^DIQ(9000014,CIEN_",",.12,"I")
+48 SET DIEN=$$GET1^DIQ(9000014,CIEN_",",.01,"I")
IF DIEN=""
QUIT
+49 ; csv
IF $$VERSION^XPDUTL("BCSV")
SET DIAG=$$ICD9^BQIUL3(DIEN,DTMNT,2)_"-"_$$ICD9^BQIUL3(DIEN,DTMNT,4)
+50 IF '$$VERSION^XPDUTL("BCSV")
SET DIAG=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")
+51 SET DIAG=DIEN_$CHAR(28)_DIAG
+52 SET NARR=$$GET1^DIQ(9000014,CIEN_",",.04,"E")
+53 SET NIEN=$$GET1^DIQ(9000014,CIEN_",",.04,"I")
+54 SET AGC=$$GET1^DIQ(9000014,CIEN_",",.11,"I")
+55 SET AGE=""
IF AGC'=""
SET AGE=AGC_$CHAR(28)_$$GET1^DIQ(9000014,CIEN_",",.11,"E")
+56 SET RIEN=$$GET1^DIQ(9000014,CIEN_",",.09,"I")
+57 IF RIEN'=""
SET FAM(RIEN)=""
+58 DO GFAM
+59 SET ARRAY(RORD,RELNM,CIEN)=CIEN_U_RIEN_U_RELAT_U_RELD_U_DIAG_U_NARR_U_AGE_U_STAT_U_$$FMTE^BQIUL1(FHXDTLM)_U_NIEN_$CHAR(28)_NARR_$CHAR(30)
End DoDot:2
+60 ;
+61 SET CIEN=""
+62 FOR
SET CIEN=$ORDER(^AUPNFHR("AA",DFN,CIEN))
IF 'CIEN
QUIT
SET RIEN=""
Begin DoDot:2
+63 FOR
SET RIEN=$ORDER(^AUPNFHR("AA",DFN,CIEN,RIEN))
IF RIEN=""
QUIT
Begin DoDot:3
+64 IF $DATA(FAM(RIEN))
QUIT
+65 ; For family without diagnoses search FAMILY HISTORY FAMILY MEMBERS file
+66 DO GFAM
+67 SET ARRAY(RORD,RELNM,"R"_RIEN)=U_RIEN_U_RELAT_U_RELD_U_U_U_U_STAT_U_$$FMTE^BQIUL1(FHXDTLM)_U_$CHAR(30)
End DoDot:3
End DoDot:2
+68 ;
+69 SET ORD=""
+70 FOR
SET ORD=$ORDER(ARRAY(ORD))
IF ORD=""
QUIT
Begin DoDot:2
+71 SET RELNM=""
+72 FOR
SET RELNM=$ORDER(ARRAY(ORD,RELNM))
IF RELNM=""
QUIT
Begin DoDot:3
+73 SET IEN=""
+74 FOR
SET IEN=$ORDER(ARRAY(ORD,RELNM,IEN))
IF IEN=""
QUIT
SET II=II+1
SET @DATA@(II)=ARRAY(ORD,RELNM,IEN)
End DoDot:3
End DoDot:2
End DoDot:1
+75 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+76 QUIT
+77 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
UPD(DATA,DFN,FHXIEN,FHXDXN,PARMS) ;EP - BQI UPDATE FAMILY HISTORY
+1 ;Input
+2 ; DFN - Patient internal entry number
+3 ; FHXIEN - Family History IEN if null create a new one
+4 ; if the FHXIEN is null then FHXDXN (the diagnosis) must be defined
+5 ; PARMS - Data values
+6 ;
+7 NEW UID,II,VFIEN,FILE,LIST,BN,BQ,PDATA,NAME,VALUE,PFIEN,PTYP,CHIEN,FIELD
+8 NEW BQIDATA,ERROR,RESULT
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BQIPTFHU",UID))
+11 KILL @DATA
+12 ;
+13 SET II=0
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTFHS D UNWIND^%ZTER"
+15 SET @DATA@(II)="I00010RESULT^T001024ERROR"_$CHAR(30)
+16 ;
+17 SET FHXIEN=$GET(FHXIEN,"")
SET FHXDXN=$GET(FHXDXN,"")
+18 IF FHXIEN=""&(FHXDXN="")
SET BMXSEC="RPC Call Failed: Needs diagnosis"
QUIT
+19 ;
+20 ;if deleting a family history record
+21 IF FHXDXN="@"
DO DEL
GOTO DONE
+22 ;
+23 SET VFIEN=$ORDER(^BQI(90506.3,"B","Family History",""))
+24 IF VFIEN=""
SET BMXSEC="RPC Call Failed: Family History Definition does not exist."
QUIT
+25 SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
+26 ;
+27 SET PARMS=$GET(PARMS,"")
+28 IF PARMS=""
Begin DoDot:1
+29 SET LIST=""
SET BN=""
+30 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+31 KILL PARMS
+32 SET PARMS=LIST
+33 KILL LIST
End DoDot:1
+34 ;
+35 IF FHXIEN=""
DO NREC
+36 ;
+37 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+38 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+39 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
IF VALUE=""
QUIT
+40 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+41 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+42 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+43 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+44 ;I PTYP="T" S VALUE=VALUE
+45 IF PTYP="C"
Begin DoDot:2
+46 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+47 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+48 SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+49 SET BQIDATA(FILE,FHXIEN_",",FIELD)=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+50 ;
+51 KILL ERROR
+52 IF $DATA(BQIDATA)>0
DO FILE^DIE("","BQIDATA","ERROR")
+53 SET RESULT=1_U
+54 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+55 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+56 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
NREC ; Create new record
+1 KILL DIC,DR,DA
+2 NEW DIC,X,Y
+3 SET DIC="^AUPNFH("
SET DIC(0)="L"
SET X=FHXDXN
SET DIC("DR")=".02////"_DFN_";.03////^S X=DT;.07////"_$GET(FHXRLTN)
+4 KILL DO,DD
DO FILE^DICN
+5 SET FHXIEN=+Y
+6 QUIT
+7 ;
DEL ; Delete a record
+1 NEW DIK,DA
+2 SET RESULT=1_U
+3 SET DIK="^AUPNFH("
+4 IF FHXIEN'=""
SET DA=FHXIEN
DO ^DIK
+5 IF FHXIEN=""
SET RESULT=-1_U_"No Family History record passed in to delete"
+6 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+7 QUIT
+8 ;
GFAM ; Get family history family members data
+1 SET RELN=$$GET1^DIQ(9000014.1,RIEN_",",.01,"I")
+2 SET RORD=$$GET1^DIQ(9999999.36,RELN_",",2103,"E")
IF RORD=""
SET RORD="~"
+3 SET RELT=$$GET1^DIQ(9000014.1,RIEN_",",.01,"E")
+4 SET RELNM=RELT
IF RELNM=""
SET RELNM="~"
+5 SET RELD=$$GET1^DIQ(9000014.1,RIEN_",",.03,"E")
+6 ;_" "_RELD
SET RELAT=""
IF RELN'=""
SET RELAT=RELN_$CHAR(28)_RELT
+7 SET STC=$$GET1^DIQ(9000014.1,RIEN_",",.04,"I")
+8 SET STT=$$GET1^DIQ(9000014.1,RIEN_",",.04,"E")
+9 SET STAT=""
IF STC'=""
SET STAT=STC_$CHAR(28)_STT
+10 SET FHXDTLM=$$GET1^DIQ(9000014.1,RIEN_",",.09,"I")
+11 QUIT
