- 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