BQIPTFHE ;VNGT/HS/BEE - Family History Data Entry ; 13 May 2009 10:35 AM
;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
;
Q
;
REL(DATA,DFN) ; EP - BQI GET FAM HIST RELATIONS
;Description
; Retrieves all of the FAMILY HISTORY FAMILY MEMBERS entries for the given DFN
;
;Input
; DFN - Patient Internal ID
;
;Output
; DATA - Name of global in which data is stored(^TMP("BQIPTFHE"))
;
NEW UID,BQII,FHRIEN,BQREL,BQIREL,RDSC,REL
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTFHE",UID))
K @DATA
;
S BQII=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(BQII)="I00010FHRIEN^T00060FHRREL^T00030FHRDES"_$C(30)
;
I $$VERSION^XPDUTL("BJPC")<2.0 D G DONE
. S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q
;
;Verify Patient DFN is populated
I $G(DFN)="" S BMXSEC="Patient DFN is required" Q
;
S BQREL="" F S BQREL=$O(^AUPNFHR("AA",DFN,BQREL)) Q:BQREL="" D
. S FHRIEN="" F S FHRIEN=$O(^AUPNFHR("AA",DFN,BQREL,FHRIEN)) Q:FHRIEN="" D
.. N BQIREL
.. D GETS^DIQ(9000014.1,FHRIEN,".01;.03","E","BQIREL")
.. S REL=$G(BQIREL(9000014.1,FHRIEN_",",".01","E"))
.. S RDSC=$G(BQIREL(9000014.1,FHRIEN_",",".03","E"))
.. S BQII=BQII+1,@DATA@(BQII)=FHRIEN_U_REL_U_RDSC_$C(30)
;
DONE ;
;
S BQII=BQII+1,@DATA@(BQII)=$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(BQII),$D(DATA) S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
COND(DATA,FHRIEN) ; EP - BQI GET FAM HIST CONDITIONS
;Description
; Retrieves all of the FAMILY HISTORY entries for the given Relation IEN
;
;Input
; FHRIEN - Relationship IEN
;
;Output
; DATA - Name of global in which data is stored(^TMP("BQIPTFHE"))
;
NEW UID,AGEO,BQII,FHCIEN,COND,DTMD,DTNT,PNAR,PROV,APCDTNQ,DIEN,FHCDX
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTFHE",UID))
K @DATA
;
S BQII=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(BQII)="I00010FHCIEN^T00060FHCDX^D00030FHCDTN^T00080FHCNAR^T00050FHCPRV^T00030FHCAAO^D00030FHCDTM^T00100APCDTNQ"_$C(30)
;
I $$VERSION^XPDUTL("BJPC")<2.0 D G DONE1
. S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q
;
;Verify that Relation IEN is populated
I $G(FHRIEN)="" S BMXSEC="FAMILY HISTORY FAMILY MEMBERS IEN IS REQUIRED" Q
;
S FHCIEN="" F S FHCIEN=$O(^AUPNFH("AE",FHRIEN,FHCIEN)) Q:FHCIEN="" D
. N BQICND
. D GETS^DIQ(9000014,FHCIEN,"**","IE","BQICND")
. ;
. ;Date Noted
. S DTNT=$G(BQICND(9000014,FHCIEN_",",".03","E"))
. ;
. ;DX Code (Condition) - With IEN
. S DIEN=$$GET1^DIQ(9000014,FHCIEN_",",.01,"I") ;Using $$GET1^DIQ as GETS^DIQ sometimes omits .01 entry
. I DIEN="" Q
. I $$VERSION^XPDUTL("BCSV") S FHCDX=$$ICD9^BQIUL3(DIEN,DTNT,2)_"-"_$$ICD9^BQIUL3(DIEN,DTNT,4) ; csv
. I '$$VERSION^XPDUTL("BCSV") S FHCDX=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")
. S COND=DIEN_$C(28)_FHCDX S:$P(COND,$C(28))="-" COND=""
. ;
. ;Narrative
. S PNAR=$G(BQICND(9000014,FHCIEN_",",".04","E"))
. ;
. ;Narrative - With IEN
. S APCDTNQ=$G(BQICND(9000014,FHCIEN_",",".04","I"))_$C(28)_PNAR
. S:$P(APCDTNQ,$C(28))="" APCDTNQ=""
. ;
. ;Provider - With IEN
. S PROV=$G(BQICND(9000014,FHCIEN_",",".08","I"))_$C(28)_$G(BQICND(9000014,FHCIEN_",",".08","E"))
. S:$P(PROV,$C(28))="" PROV=""
. ;
. ;Age at Onset
. S AGEO=$G(BQICND(9000014,FHCIEN_",",".11","I"))_$C(28)_$G(BQICND(9000014,FHCIEN_",",".11","E"))
. S:$P(AGEO,$C(28))="" AGEO=""
. ;
. ;Date last modified
. S DTMD=$G(BQICND(9000014,FHCIEN_",",".12","E"))
. ;
. S BQII=BQII+1,@DATA@(BQII)=FHCIEN_U_COND_U_DTNT_U_PNAR_U_PROV_U_AGEO_U_DTMD_U_APCDTNQ_$C(30)
;
DONE1 ;
;
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
UPDR(DATA,DFN,TYPE,FHRIEN,PARMS) ; EP - BQI UPDATE FAM HIST RELATIONS
;Input
; DFN - Patient internal entry number
; TYPE - 'A' to add/edit or 'D' to delete (Delete currently deactivated)
; FHRIEN - FAMILY HISTORY FAMILY MEMBERS IEN (Required for Edit/Delete)
; PARMS - Data values
;
NEW UID,BQ,BQIDATA,BQII,BQITMP,ERROR,FILE,MSG,RESULT,VFIEN
NEW FHRREL,FHRDES,FHRSTS,FHRAAD,FHRCOD,FHRMB,FHRMBT,FHRDTU,FHRDTA
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTFHE",UID))
K @DATA
;
S BQII=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(BQII)="I00010RESULT^T01024MSG^I00010FHRIEN"_$C(30)
;
S VFIEN=$O(^BQI(90506.3,"B","Family History Relations",""))
I VFIEN="" S BMXSEC="RPC Call Failed: Family History Relations Definition does not exist." Q
S FILE=$P(^BQI(90506.3,VFIEN,0),U,2) I FILE="" S BMXSEC="RPC Call Failed: Family History Relations Definition FILE NUMBER is null." Q
;
S DFN=$G(DFN,""),TYPE=$G(TYPE,""),FHRIEN=$G(FHRIEN,"")
I TYPE'="A",TYPE'="D" S BMXSEC="TYPE value is required (A-Add/Edit, D-Delete)" Q
I TYPE="A",DFN="" S BMXSEC="Patient DFN value is required" Q
I TYPE="D",FHRIEN="" S BMXSEC="Pointer to FAMILY HISTORY FAMILY MEMBERS is required for deletes" Q
;
;Handle Deletes
I TYPE="D" D G DONER
. S RESULT=$$DELR(FHRIEN)
. S BQII=BQII+1,@DATA@(BQII)=RESULT_$C(30)
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. N LIST,BN
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
;Pull Parameter Data
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. N CHIEN,FIELD,NAME,PDATA,PFIEN,PTYP,VALUE
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1) I NAME="" Q
. S VALUE=$P(PDATA,"=",2,99)
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
. I VALUE="",FIELD'=".001" S VALUE="@"
. S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
. I PTYP="D" S VALUE=$$DATE^BQIUL1(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 @NAME=VALUE
. I FIELD'=".001",FIELD]"" S BQITMP(FIELD)=VALUE
;
;Handle Adds
I FHRIEN="" D NEWFR Q:$G(BMXSEC)'=""
;
;Update Date Updated
S BQITMP(".09")=DT
;
;File Record Data
M BQIDATA(FILE,FHRIEN_",")=BQITMP
I $D(BQIDATA)>0 D FILE^DIE("","BQIDATA","ERROR")
S RESULT=1_U_U_FHRIEN
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
S BQII=BQII+1,@DATA@(BQII)=RESULT_$C(30)
;
DONER ;
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
NEWFR ;Create FAMILY HISTORY FAMILY MEMBERS record
NEW DIC,DA,DR,X,Y
I $G(FHRREL)="" S BMXSEC="RELATIONSHIP value is required" Q
S DIC="^AUPNFHR(",DIC(0)="L",X=FHRREL,DIC("DR")=".02////"_DFN_";.11////^S X=DT;.09////^S X=DT"
K DO,DD D FILE^DICN
S FHRIEN=+Y
I 'FHRIEN S BMXSEC="Unable to create new FAMILY HISTORY FAMILY MEMBERS RECORD"
Q
;
UPDC(DATA,DFN,TYPE,FHRIEN,FHCIEN,PARMS) ; EP - BQI UPDATE FAM HIST CONDITIONS
;Input
; DFN - Patient internal entry number
; TYPE - 'A' to add/edit or 'D' to delete ('E' gets converted to 'A')
; FHRIEN - FAMILY HISTORY FAMILY MEMBER IEN (Required for Add/Edit)
; FHCIEN - FAMILY HISTORY IEN (Required for Edit/Delete)
; PARMS - Data values
;
NEW UID,BQ,BQIDATA,BQII,BQITMP,ERROR,FILE,MSG,RESULT,VFIEN
NEW FHCDX,FHCNAR,FHCPRV,FHCAAO,FHCDTN,APCDTNQ
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTFHE",UID))
K @DATA
;
S BQII=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(BQII)="I00010RESULT^T01024MSG^I00010FHCIEN"_$C(30)
;
S VFIEN=$O(^BQI(90506.3,"B","Family History Conditions",""))
I VFIEN="" S BMXSEC="RPC Call Failed: Family History Conditions Definition does not exist." Q
S FILE=$P(^BQI(90506.3,VFIEN,0),U,2) I FILE="" S BMXSEC="RPC Call Failed: Family History Conditions Definition FILE NUMBER is null." Q
;
S DFN=$G(DFN,""),TYPE=$G(TYPE,""),FHRIEN=$G(FHRIEN,""),FHCIEN=$G(FHCIEN,"")
I DFN="" S BMXSEC="Patient DFN value is required" Q
;
;Convert TYPE 'E' to 'A'
S:TYPE="E" TYPE="A"
;
I TYPE'="A",TYPE'="D" S BMXSEC="TYPE value is required (A-Add/Edit, D-Delete)" Q
I TYPE="A",DFN="" S BMXSEC="Patient DFN value is required" Q
I TYPE="A",FHRIEN="" S BMXSEC="Pointer to FAMILY HISTORY FAMILY MEMBERS is required" Q
I TYPE="D",FHCIEN="" S BMXSEC="Pointer to FAMILY HISTORY is required for deletes"
;
;Handle Deletes
I TYPE="D" D G DONEC
. S RESULT=$$DELC(FHCIEN)
. S BQII=BQII+1,@DATA@(BQII)=RESULT_$C(30)
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. N LIST,BN
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
;Pull Parameter Data
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. N CHIEN,FIELD,NAME,PDATA,PFIEN,PTYP,VALUE
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1) I NAME="" Q
. S VALUE=$P(PDATA,"=",2,99)
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
. I VALUE="",FIELD'=".001" S VALUE="@"
. S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
. I PTYP="D" S VALUE=$$DATE^BQIUL1(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 @NAME=VALUE
. I FIELD'=".001",FIELD]"" S BQITMP(FIELD)=VALUE
;
;Handle Adds
I FHCIEN="" D NEWFC Q:$G(BMXSEC)'=""
;
;Special code to fill in Diagnosis Narrative (if blank)
I $G(BQITMP(".04"))="",$G(BQITMP(".01"))]"" D
. N TEXT
. I $$VERSION^XPDUTL("BCSV") S TEXT=$P($$ICDDX^ICDCODE(BQITMP(".01"),DT),U,4)
. I TEXT]"" D
.. N DIC,DLAYGO,X,Y,IEN
.. S DIC(0)="LX",DIC="^AUTNPOV(",DLAYGO=9999999.27,X=TEXT
.. D ^DIC
.. S IEN=+Y
.. I IEN=-1 K DO,DD D FILE^DICN S TEXT=+Y
. S BQITMP(".04")=TEXT ;Adapted from COND^APCDFH (APCD FAMILY HISTORY ADD/EDIT option)
;
;Update Relation IEN (Needed For Cases When Condition Gets Moved)
S BQITMP(".09")=$G(FHRIEN)
;
;Update Date Last Modified
S BQITMP(".12")=DT
;
;File Record Data
M BQIDATA(FILE,FHCIEN_",")=BQITMP
I $D(BQIDATA)>0 D FILE^DIE("","BQIDATA","ERROR")
S RESULT=1_U_U_FHCIEN
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
S BQII=BQII+1,@DATA@(BQII)=RESULT_$C(30)
;
DONEC ;
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
NEWFC ;Create FAMILY HISTORY record
NEW DIC,DA,DR,X,Y
I $G(FHCDX)="" S BMXSEC="CONDITION value is required" Q
S DIC="^AUPNFH(",DIC(0)="L",X=FHCDX,DIC("DR")=".02////"_DFN_";.03////^S X=DT;.09////"_$G(FHRIEN)_";.12////^S X=DT"
K DO,DD D FILE^DICN
S FHCIEN=+Y
I 'FHCIEN S BMXSEC="Unable to create new FAMILY HISTORY RECORD"
Q
;
DELR(FHRIEN) ;Delete a FAMILY HISTORY FAMILY MEMBERS record as well as any linked FAMILY HISTORY records
;
NEW DIK,DA,RESULT
;
I FHRIEN="" S RESULT=-1_U_"No FAMILY HISTORY FAMILY MEMBERS record passed in to delete" Q RESULT
;
;Verify that there are no linked conditions - If yes, cannot delete entry
I $O(^AUPNFH("AE",FHRIEN,""))]"" S RESULT=-1_U_"This relation has conditions linked to it and cannot be deleted" Q RESULT
;
;Delete FAMILY HISTORY FAMILY MEMBERS record
S RESULT=1_U
S DIK="^AUPNFHR(",DA=FHRIEN D ^DIK
Q RESULT
;
DELC(FHCIEN) ;Delete a FAMILY HISTORY record
;
NEW DIK,DA,RESULT
;
I FHCIEN="" S RESULT=-1_U_"No FAMILY HISTORY record passed in to delete" Q RESULT
;
S RESULT=1_U
S DIK="^AUPNFH(",DA=FHCIEN D ^DIK
Q RESULT
BQIPTFHE ;VNGT/HS/BEE - Family History Data Entry ; 13 May 2009 10:35 AM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
+2 ;
+3 QUIT
+4 ;
REL(DATA,DFN) ; EP - BQI GET FAM HIST RELATIONS
+1 ;Description
+2 ; Retrieves all of the FAMILY HISTORY FAMILY MEMBERS entries for the given DFN
+3 ;
+4 ;Input
+5 ; DFN - Patient Internal ID
+6 ;
+7 ;Output
+8 ; DATA - Name of global in which data is stored(^TMP("BQIPTFHE"))
+9 ;
+10 NEW UID,BQII,FHRIEN,BQREL,BQIREL,RDSC,REL
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("BQIPTFHE",UID))
+13 KILL @DATA
+14 ;
+15 SET BQII=0
+16 ;
+17 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER"
+18 ;
+19 SET @DATA@(BQII)="I00010FHRIEN^T00060FHRREL^T00030FHRDES"_$CHAR(30)
+20 ;
+21 IF $$VERSION^XPDUTL("BJPC")<2.0
Begin DoDot:1
+22 SET BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS"
QUIT
End DoDot:1
GOTO DONE
+23 ;
+24 ;Verify Patient DFN is populated
+25 IF $GET(DFN)=""
SET BMXSEC="Patient DFN is required"
QUIT
+26 ;
+27 SET BQREL=""
FOR
SET BQREL=$ORDER(^AUPNFHR("AA",DFN,BQREL))
IF BQREL=""
QUIT
Begin DoDot:1
+28 SET FHRIEN=""
FOR
SET FHRIEN=$ORDER(^AUPNFHR("AA",DFN,BQREL,FHRIEN))
IF FHRIEN=""
QUIT
Begin DoDot:2
+29 NEW BQIREL
+30 DO GETS^DIQ(9000014.1,FHRIEN,".01;.03","E","BQIREL")
+31 SET REL=$GET(BQIREL(9000014.1,FHRIEN_",",".01","E"))
+32 SET RDSC=$GET(BQIREL(9000014.1,FHRIEN_",",".03","E"))
+33 SET BQII=BQII+1
SET @DATA@(BQII)=FHRIEN_U_REL_U_RDSC_$CHAR(30)
End DoDot:2
End DoDot:1
+34 ;
DONE ;
+1 ;
+2 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+3 QUIT
+4 ;
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(BQII)
IF $DATA(DATA)
SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+6 QUIT
+7 ;
COND(DATA,FHRIEN) ; EP - BQI GET FAM HIST CONDITIONS
+1 ;Description
+2 ; Retrieves all of the FAMILY HISTORY entries for the given Relation IEN
+3 ;
+4 ;Input
+5 ; FHRIEN - Relationship IEN
+6 ;
+7 ;Output
+8 ; DATA - Name of global in which data is stored(^TMP("BQIPTFHE"))
+9 ;
+10 NEW UID,AGEO,BQII,FHCIEN,COND,DTMD,DTNT,PNAR,PROV,APCDTNQ,DIEN,FHCDX
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("BQIPTFHE",UID))
+13 KILL @DATA
+14 ;
+15 SET BQII=0
+16 ;
+17 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER"
+18 ;
+19 SET @DATA@(BQII)="I00010FHCIEN^T00060FHCDX^D00030FHCDTN^T00080FHCNAR^T00050FHCPRV^T00030FHCAAO^D00030FHCDTM^T00100APCDTNQ"_$CHAR(30)
+20 ;
+21 IF $$VERSION^XPDUTL("BJPC")<2.0
Begin DoDot:1
+22 SET BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS"
QUIT
End DoDot:1
GOTO DONE1
+23 ;
+24 ;Verify that Relation IEN is populated
+25 IF $GET(FHRIEN)=""
SET BMXSEC="FAMILY HISTORY FAMILY MEMBERS IEN IS REQUIRED"
QUIT
+26 ;
+27 SET FHCIEN=""
FOR
SET FHCIEN=$ORDER(^AUPNFH("AE",FHRIEN,FHCIEN))
IF FHCIEN=""
QUIT
Begin DoDot:1
+28 NEW BQICND
+29 DO GETS^DIQ(9000014,FHCIEN,"**","IE","BQICND")
+30 ;
+31 ;Date Noted
+32 SET DTNT=$GET(BQICND(9000014,FHCIEN_",",".03","E"))
+33 ;
+34 ;DX Code (Condition) - With IEN
+35 ;Using $$GET1^DIQ as GETS^DIQ sometimes omits .01 entry
SET DIEN=$$GET1^DIQ(9000014,FHCIEN_",",.01,"I")
+36 IF DIEN=""
QUIT
+37 ; csv
IF $$VERSION^XPDUTL("BCSV")
SET FHCDX=$$ICD9^BQIUL3(DIEN,DTNT,2)_"-"_$$ICD9^BQIUL3(DIEN,DTNT,4)
+38 IF '$$VERSION^XPDUTL("BCSV")
SET FHCDX=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")
+39 SET COND=DIEN_$CHAR(28)_FHCDX
IF $PIECE(COND,$CHAR(28))="-"
SET COND=""
+40 ;
+41 ;Narrative
+42 SET PNAR=$GET(BQICND(9000014,FHCIEN_",",".04","E"))
+43 ;
+44 ;Narrative - With IEN
+45 SET APCDTNQ=$GET(BQICND(9000014,FHCIEN_",",".04","I"))_$CHAR(28)_PNAR
+46 IF $PIECE(APCDTNQ,$CHAR(28))=""
SET APCDTNQ=""
+47 ;
+48 ;Provider - With IEN
+49 SET PROV=$GET(BQICND(9000014,FHCIEN_",",".08","I"))_$CHAR(28)_$GET(BQICND(9000014,FHCIEN_",",".08","E"))
+50 IF $PIECE(PROV,$CHAR(28))=""
SET PROV=""
+51 ;
+52 ;Age at Onset
+53 SET AGEO=$GET(BQICND(9000014,FHCIEN_",",".11","I"))_$CHAR(28)_$GET(BQICND(9000014,FHCIEN_",",".11","E"))
+54 IF $PIECE(AGEO,$CHAR(28))=""
SET AGEO=""
+55 ;
+56 ;Date last modified
+57 SET DTMD=$GET(BQICND(9000014,FHCIEN_",",".12","E"))
+58 ;
+59 SET BQII=BQII+1
SET @DATA@(BQII)=FHCIEN_U_COND_U_DTNT_U_PNAR_U_PROV_U_AGEO_U_DTMD_U_APCDTNQ_$CHAR(30)
End DoDot:1
+60 ;
DONE1 ;
+1 ;
+2 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+3 QUIT
+4 ;
UPDR(DATA,DFN,TYPE,FHRIEN,PARMS) ; EP - BQI UPDATE FAM HIST RELATIONS
+1 ;Input
+2 ; DFN - Patient internal entry number
+3 ; TYPE - 'A' to add/edit or 'D' to delete (Delete currently deactivated)
+4 ; FHRIEN - FAMILY HISTORY FAMILY MEMBERS IEN (Required for Edit/Delete)
+5 ; PARMS - Data values
+6 ;
+7 NEW UID,BQ,BQIDATA,BQII,BQITMP,ERROR,FILE,MSG,RESULT,VFIEN
+8 NEW FHRREL,FHRDES,FHRSTS,FHRAAD,FHRCOD,FHRMB,FHRMBT,FHRDTU,FHRDTA
+9 ;
+10 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+11 SET DATA=$NAME(^TMP("BQIPTFHE",UID))
+12 KILL @DATA
+13 ;
+14 SET BQII=0
+15 ;
+16 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER"
+17 ;
+18 SET @DATA@(BQII)="I00010RESULT^T01024MSG^I00010FHRIEN"_$CHAR(30)
+19 ;
+20 SET VFIEN=$ORDER(^BQI(90506.3,"B","Family History Relations",""))
+21 IF VFIEN=""
SET BMXSEC="RPC Call Failed: Family History Relations Definition does not exist."
QUIT
+22 SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
IF FILE=""
SET BMXSEC="RPC Call Failed: Family History Relations Definition FILE NUMBER is null."
QUIT
+23 ;
+24 SET DFN=$GET(DFN,"")
SET TYPE=$GET(TYPE,"")
SET FHRIEN=$GET(FHRIEN,"")
+25 IF TYPE'="A"
IF TYPE'="D"
SET BMXSEC="TYPE value is required (A-Add/Edit, D-Delete)"
QUIT
+26 IF TYPE="A"
IF DFN=""
SET BMXSEC="Patient DFN value is required"
QUIT
+27 IF TYPE="D"
IF FHRIEN=""
SET BMXSEC="Pointer to FAMILY HISTORY FAMILY MEMBERS is required for deletes"
QUIT
+28 ;
+29 ;Handle Deletes
+30 IF TYPE="D"
Begin DoDot:1
+31 SET RESULT=$$DELR(FHRIEN)
+32 SET BQII=BQII+1
SET @DATA@(BQII)=RESULT_$CHAR(30)
End DoDot:1
GOTO DONER
+33 ;
+34 SET PARMS=$GET(PARMS,"")
+35 IF PARMS=""
Begin DoDot:1
+36 NEW LIST,BN
+37 SET LIST=""
SET BN=""
+38 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+39 KILL PARMS
+40 SET PARMS=LIST
+41 KILL LIST
End DoDot:1
+42 ;
+43 ;Pull Parameter Data
+44 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+45 NEW CHIEN,FIELD,NAME,PDATA,PFIEN,PTYP,VALUE
+46 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+47 SET NAME=$PIECE(PDATA,"=",1)
IF NAME=""
QUIT
+48 SET VALUE=$PIECE(PDATA,"=",2,99)
+49 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+50 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+51 SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+52 IF VALUE=""
IF FIELD'=".001"
SET VALUE="@"
+53 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+54 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+55 IF PTYP="C"
Begin DoDot:2
+56 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+57 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+58 SET @NAME=VALUE
+59 IF FIELD'=".001"
IF FIELD]""
SET BQITMP(FIELD)=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+60 ;
+61 ;Handle Adds
+62 IF FHRIEN=""
DO NEWFR
IF $GET(BMXSEC)'=""
QUIT
+63 ;
+64 ;Update Date Updated
+65 SET BQITMP(".09")=DT
+66 ;
+67 ;File Record Data
+68 MERGE BQIDATA(FILE,FHRIEN_",")=BQITMP
+69 IF $DATA(BQIDATA)>0
DO FILE^DIE("","BQIDATA","ERROR")
+70 SET RESULT=1_U_U_FHRIEN
+71 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+72 SET BQII=BQII+1
SET @DATA@(BQII)=RESULT_$CHAR(30)
+73 ;
DONER ;
+1 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+2 QUIT
+3 ;
NEWFR ;Create FAMILY HISTORY FAMILY MEMBERS record
+1 NEW DIC,DA,DR,X,Y
+2 IF $GET(FHRREL)=""
SET BMXSEC="RELATIONSHIP value is required"
QUIT
+3 SET DIC="^AUPNFHR("
SET DIC(0)="L"
SET X=FHRREL
SET DIC("DR")=".02////"_DFN_";.11////^S X=DT;.09////^S X=DT"
+4 KILL DO,DD
DO FILE^DICN
+5 SET FHRIEN=+Y
+6 IF 'FHRIEN
SET BMXSEC="Unable to create new FAMILY HISTORY FAMILY MEMBERS RECORD"
+7 QUIT
+8 ;
UPDC(DATA,DFN,TYPE,FHRIEN,FHCIEN,PARMS) ; EP - BQI UPDATE FAM HIST CONDITIONS
+1 ;Input
+2 ; DFN - Patient internal entry number
+3 ; TYPE - 'A' to add/edit or 'D' to delete ('E' gets converted to 'A')
+4 ; FHRIEN - FAMILY HISTORY FAMILY MEMBER IEN (Required for Add/Edit)
+5 ; FHCIEN - FAMILY HISTORY IEN (Required for Edit/Delete)
+6 ; PARMS - Data values
+7 ;
+8 NEW UID,BQ,BQIDATA,BQII,BQITMP,ERROR,FILE,MSG,RESULT,VFIEN
+9 NEW FHCDX,FHCNAR,FHCPRV,FHCAAO,FHCDTN,APCDTNQ
+10 ;
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("BQIPTFHE",UID))
+13 KILL @DATA
+14 ;
+15 SET BQII=0
+16 ;
+17 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER"
+18 ;
+19 SET @DATA@(BQII)="I00010RESULT^T01024MSG^I00010FHCIEN"_$CHAR(30)
+20 ;
+21 SET VFIEN=$ORDER(^BQI(90506.3,"B","Family History Conditions",""))
+22 IF VFIEN=""
SET BMXSEC="RPC Call Failed: Family History Conditions Definition does not exist."
QUIT
+23 SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
IF FILE=""
SET BMXSEC="RPC Call Failed: Family History Conditions Definition FILE NUMBER is null."
QUIT
+24 ;
+25 SET DFN=$GET(DFN,"")
SET TYPE=$GET(TYPE,"")
SET FHRIEN=$GET(FHRIEN,"")
SET FHCIEN=$GET(FHCIEN,"")
+26 IF DFN=""
SET BMXSEC="Patient DFN value is required"
QUIT
+27 ;
+28 ;Convert TYPE 'E' to 'A'
+29 IF TYPE="E"
SET TYPE="A"
+30 ;
+31 IF TYPE'="A"
IF TYPE'="D"
SET BMXSEC="TYPE value is required (A-Add/Edit, D-Delete)"
QUIT
+32 IF TYPE="A"
IF DFN=""
SET BMXSEC="Patient DFN value is required"
QUIT
+33 IF TYPE="A"
IF FHRIEN=""
SET BMXSEC="Pointer to FAMILY HISTORY FAMILY MEMBERS is required"
QUIT
+34 IF TYPE="D"
IF FHCIEN=""
SET BMXSEC="Pointer to FAMILY HISTORY is required for deletes"
+35 ;
+36 ;Handle Deletes
+37 IF TYPE="D"
Begin DoDot:1
+38 SET RESULT=$$DELC(FHCIEN)
+39 SET BQII=BQII+1
SET @DATA@(BQII)=RESULT_$CHAR(30)
End DoDot:1
GOTO DONEC
+40 ;
+41 SET PARMS=$GET(PARMS,"")
+42 IF PARMS=""
Begin DoDot:1
+43 NEW LIST,BN
+44 SET LIST=""
SET BN=""
+45 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+46 KILL PARMS
+47 SET PARMS=LIST
+48 KILL LIST
End DoDot:1
+49 ;
+50 ;Pull Parameter Data
+51 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+52 NEW CHIEN,FIELD,NAME,PDATA,PFIEN,PTYP,VALUE
+53 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+54 SET NAME=$PIECE(PDATA,"=",1)
IF NAME=""
QUIT
+55 SET VALUE=$PIECE(PDATA,"=",2,99)
+56 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+57 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+58 SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+59 IF VALUE=""
IF FIELD'=".001"
SET VALUE="@"
+60 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+61 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+62 IF PTYP="C"
Begin DoDot:2
+63 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+64 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+65 SET @NAME=VALUE
+66 IF FIELD'=".001"
IF FIELD]""
SET BQITMP(FIELD)=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+67 ;
+68 ;Handle Adds
+69 IF FHCIEN=""
DO NEWFC
IF $GET(BMXSEC)'=""
QUIT
+70 ;
+71 ;Special code to fill in Diagnosis Narrative (if blank)
+72 IF $GET(BQITMP(".04"))=""
IF $GET(BQITMP(".01"))]""
Begin DoDot:1
+73 NEW TEXT
+74 IF $$VERSION^XPDUTL("BCSV")
SET TEXT=$PIECE($$ICDDX^ICDCODE(BQITMP(".01"),DT),U,4)
+75 IF TEXT]""
Begin DoDot:2
+76 NEW DIC,DLAYGO,X,Y,IEN
+77 SET DIC(0)="LX"
SET DIC="^AUTNPOV("
SET DLAYGO=9999999.27
SET X=TEXT
+78 DO ^DIC
+79 SET IEN=+Y
+80 IF IEN=-1
KILL DO,DD
DO FILE^DICN
SET TEXT=+Y
End DoDot:2
+81 ;Adapted from COND^APCDFH (APCD FAMILY HISTORY ADD/EDIT option)
SET BQITMP(".04")=TEXT
End DoDot:1
+82 ;
+83 ;Update Relation IEN (Needed For Cases When Condition Gets Moved)
+84 SET BQITMP(".09")=$GET(FHRIEN)
+85 ;
+86 ;Update Date Last Modified
+87 SET BQITMP(".12")=DT
+88 ;
+89 ;File Record Data
+90 MERGE BQIDATA(FILE,FHCIEN_",")=BQITMP
+91 IF $DATA(BQIDATA)>0
DO FILE^DIE("","BQIDATA","ERROR")
+92 SET RESULT=1_U_U_FHCIEN
+93 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+94 SET BQII=BQII+1
SET @DATA@(BQII)=RESULT_$CHAR(30)
+95 ;
DONEC ;
+1 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+2 QUIT
+3 ;
NEWFC ;Create FAMILY HISTORY record
+1 NEW DIC,DA,DR,X,Y
+2 IF $GET(FHCDX)=""
SET BMXSEC="CONDITION value is required"
QUIT
+3 SET DIC="^AUPNFH("
SET DIC(0)="L"
SET X=FHCDX
SET DIC("DR")=".02////"_DFN_";.03////^S X=DT;.09////"_$GET(FHRIEN)_";.12////^S X=DT"
+4 KILL DO,DD
DO FILE^DICN
+5 SET FHCIEN=+Y
+6 IF 'FHCIEN
SET BMXSEC="Unable to create new FAMILY HISTORY RECORD"
+7 QUIT
+8 ;
DELR(FHRIEN) ;Delete a FAMILY HISTORY FAMILY MEMBERS record as well as any linked FAMILY HISTORY records
+1 ;
+2 NEW DIK,DA,RESULT
+3 ;
+4 IF FHRIEN=""
SET RESULT=-1_U_"No FAMILY HISTORY FAMILY MEMBERS record passed in to delete"
QUIT RESULT
+5 ;
+6 ;Verify that there are no linked conditions - If yes, cannot delete entry
+7 IF $ORDER(^AUPNFH("AE",FHRIEN,""))]""
SET RESULT=-1_U_"This relation has conditions linked to it and cannot be deleted"
QUIT RESULT
+8 ;
+9 ;Delete FAMILY HISTORY FAMILY MEMBERS record
+10 SET RESULT=1_U
+11 SET DIK="^AUPNFHR("
SET DA=FHRIEN
DO ^DIK
+12 QUIT RESULT
+13 ;
DELC(FHCIEN) ;Delete a FAMILY HISTORY record
+1 ;
+2 NEW DIK,DA,RESULT
+3 ;
+4 IF FHCIEN=""
SET RESULT=-1_U_"No FAMILY HISTORY record passed in to delete"
QUIT RESULT
+5 ;
+6 SET RESULT=1_U
+7 SET DIK="^AUPNFH("
SET DA=FHCIEN
DO ^DIK
+8 QUIT RESULT
