Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIPTFHE

BQIPTFHE.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q
  1. ;
  1. REL(DATA,DFN) ; EP - BQI GET FAM HIST RELATIONS
  1. ;Description
  1. ; Retrieves all of the FAMILY HISTORY FAMILY MEMBERS entries for the given DFN
  1. ;
  1. ;Input
  1. ; DFN - Patient Internal ID
  1. ;
  1. ;Output
  1. ; DATA - Name of global in which data is stored(^TMP("BQIPTFHE"))
  1. ;
  1. NEW UID,BQII,FHRIEN,BQREL,BQIREL,RDSC,REL
  1. S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1. S DATA=$NA(^TMP("BQIPTFHE",UID))
  1. K @DATA
  1. ;
  1. S BQII=0
  1. ;
  1. NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1. ;
  1. S @DATA@(BQII)="I00010FHRIEN^T00060FHRREL^T00030FHRDES"_$C(30)
  1. ;
  1. I $$VERSION^XPDUTL("BJPC")<2.0 D G DONE
  1. . S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q
  1. ;
  1. ;Verify Patient DFN is populated
  1. I $G(DFN)="" S BMXSEC="Patient DFN is required" Q
  1. ;
  1. S BQREL="" F S BQREL=$O(^AUPNFHR("AA",DFN,BQREL)) Q:BQREL="" D
  1. . S FHRIEN="" F S FHRIEN=$O(^AUPNFHR("AA",DFN,BQREL,FHRIEN)) Q:FHRIEN="" D
  1. .. N BQIREL
  1. .. D GETS^DIQ(9000014.1,FHRIEN,".01;.03","E","BQIREL")
  1. .. S REL=$G(BQIREL(9000014.1,FHRIEN_",",".01","E"))
  1. .. S RDSC=$G(BQIREL(9000014.1,FHRIEN_",",".03","E"))
  1. .. S BQII=BQII+1,@DATA@(BQII)=FHRIEN_U_REL_U_RDSC_$C(30)
  1. ;
  1. DONE ;
  1. ;
  1. S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1. Q
  1. ;
  1. ERR ;
  1. D ^%ZTER
  1. NEW Y,ERRDTM
  1. S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1. S BMXSEC="Recording that an error occurred at "_ERRDTM
  1. I $D(BQII),$D(DATA) S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1. Q
  1. ;
  1. COND(DATA,FHRIEN) ; EP - BQI GET FAM HIST CONDITIONS
  1. ;Description
  1. ; Retrieves all of the FAMILY HISTORY entries for the given Relation IEN
  1. ;
  1. ;Input
  1. ; FHRIEN - Relationship IEN
  1. ;
  1. ;Output
  1. ; DATA - Name of global in which data is stored(^TMP("BQIPTFHE"))
  1. ;
  1. NEW UID,AGEO,BQII,FHCIEN,COND,DTMD,DTNT,PNAR,PROV,APCDTNQ,DIEN,FHCDX
  1. S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1. S DATA=$NA(^TMP("BQIPTFHE",UID))
  1. K @DATA
  1. ;
  1. S BQII=0
  1. ;
  1. NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1. ;
  1. S @DATA@(BQII)="I00010FHCIEN^T00060FHCDX^D00030FHCDTN^T00080FHCNAR^T00050FHCPRV^T00030FHCAAO^D00030FHCDTM^T00100APCDTNQ"_$C(30)
  1. ;
  1. I $$VERSION^XPDUTL("BJPC")<2.0 D G DONE1
  1. . S BMXSEC="RPC Call Failed: IHS PCC SUITE 2.0 must be installed in RPMS" Q
  1. ;
  1. ;Verify that Relation IEN is populated
  1. I $G(FHRIEN)="" S BMXSEC="FAMILY HISTORY FAMILY MEMBERS IEN IS REQUIRED" Q
  1. ;
  1. S FHCIEN="" F S FHCIEN=$O(^AUPNFH("AE",FHRIEN,FHCIEN)) Q:FHCIEN="" D
  1. . N BQICND
  1. . D GETS^DIQ(9000014,FHCIEN,"**","IE","BQICND")
  1. . ;
  1. . ;Date Noted
  1. . S DTNT=$G(BQICND(9000014,FHCIEN_",",".03","E"))
  1. . ;
  1. . ;DX Code (Condition) - With IEN
  1. . S DIEN=$$GET1^DIQ(9000014,FHCIEN_",",.01,"I") ;Using $$GET1^DIQ as GETS^DIQ sometimes omits .01 entry
  1. . I DIEN="" Q
  1. . I $$VERSION^XPDUTL("BCSV") S FHCDX=$$ICD9^BQIUL3(DIEN,DTNT,2)_"-"_$$ICD9^BQIUL3(DIEN,DTNT,4) ; csv
  1. . I '$$VERSION^XPDUTL("BCSV") S FHCDX=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")
  1. . S COND=DIEN_$C(28)_FHCDX S:$P(COND,$C(28))="-" COND=""
  1. . ;
  1. . ;Narrative
  1. . S PNAR=$G(BQICND(9000014,FHCIEN_",",".04","E"))
  1. . ;
  1. . ;Narrative - With IEN
  1. . S APCDTNQ=$G(BQICND(9000014,FHCIEN_",",".04","I"))_$C(28)_PNAR
  1. . S:$P(APCDTNQ,$C(28))="" APCDTNQ=""
  1. . ;
  1. . ;Provider - With IEN
  1. . S PROV=$G(BQICND(9000014,FHCIEN_",",".08","I"))_$C(28)_$G(BQICND(9000014,FHCIEN_",",".08","E"))
  1. . S:$P(PROV,$C(28))="" PROV=""
  1. . ;
  1. . ;Age at Onset
  1. . S AGEO=$G(BQICND(9000014,FHCIEN_",",".11","I"))_$C(28)_$G(BQICND(9000014,FHCIEN_",",".11","E"))
  1. . S:$P(AGEO,$C(28))="" AGEO=""
  1. . ;
  1. . ;Date last modified
  1. . S DTMD=$G(BQICND(9000014,FHCIEN_",",".12","E"))
  1. . ;
  1. . S BQII=BQII+1,@DATA@(BQII)=FHCIEN_U_COND_U_DTNT_U_PNAR_U_PROV_U_AGEO_U_DTMD_U_APCDTNQ_$C(30)
  1. ;
  1. DONE1 ;
  1. ;
  1. S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1. Q
  1. ;
  1. UPDR(DATA,DFN,TYPE,FHRIEN,PARMS) ; EP - BQI UPDATE FAM HIST RELATIONS
  1. ;Input
  1. ; DFN - Patient internal entry number
  1. ; TYPE - 'A' to add/edit or 'D' to delete (Delete currently deactivated)
  1. ; FHRIEN - FAMILY HISTORY FAMILY MEMBERS IEN (Required for Edit/Delete)
  1. ; PARMS - Data values
  1. ;
  1. NEW UID,BQ,BQIDATA,BQII,BQITMP,ERROR,FILE,MSG,RESULT,VFIEN
  1. NEW FHRREL,FHRDES,FHRSTS,FHRAAD,FHRCOD,FHRMB,FHRMBT,FHRDTU,FHRDTA
  1. ;
  1. S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1. S DATA=$NA(^TMP("BQIPTFHE",UID))
  1. K @DATA
  1. ;
  1. S BQII=0
  1. ;
  1. NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1. ;
  1. S @DATA@(BQII)="I00010RESULT^T01024MSG^I00010FHRIEN"_$C(30)
  1. ;
  1. S VFIEN=$O(^BQI(90506.3,"B","Family History Relations",""))
  1. I VFIEN="" S BMXSEC="RPC Call Failed: Family History Relations Definition does not exist." Q
  1. 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
  1. ;
  1. S DFN=$G(DFN,""),TYPE=$G(TYPE,""),FHRIEN=$G(FHRIEN,"")
  1. I TYPE'="A",TYPE'="D" S BMXSEC="TYPE value is required (A-Add/Edit, D-Delete)" Q
  1. I TYPE="A",DFN="" S BMXSEC="Patient DFN value is required" Q
  1. I TYPE="D",FHRIEN="" S BMXSEC="Pointer to FAMILY HISTORY FAMILY MEMBERS is required for deletes" Q
  1. ;
  1. ;Handle Deletes
  1. I TYPE="D" D G DONER
  1. . S RESULT=$$DELR(FHRIEN)
  1. . S BQII=BQII+1,@DATA@(BQII)=RESULT_$C(30)
  1. ;
  1. S PARMS=$G(PARMS,"")
  1. I PARMS="" D
  1. . N LIST,BN
  1. . S LIST="",BN=""
  1. . F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
  1. . K PARMS
  1. . S PARMS=LIST
  1. . K LIST
  1. ;
  1. ;Pull Parameter Data
  1. F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
  1. . N CHIEN,FIELD,NAME,PDATA,PFIEN,PTYP,VALUE
  1. . S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
  1. . S NAME=$P(PDATA,"=",1) I NAME="" Q
  1. . S VALUE=$P(PDATA,"=",2,99)
  1. . S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
  1. . I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
  1. . S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
  1. . I VALUE="",FIELD'=".001" S VALUE="@"
  1. . S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
  1. . I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
  1. . I PTYP="C" D
  1. .. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
  1. .. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
  1. . S @NAME=VALUE
  1. . I FIELD'=".001",FIELD]"" S BQITMP(FIELD)=VALUE
  1. ;
  1. ;Handle Adds
  1. I FHRIEN="" D NEWFR Q:$G(BMXSEC)'=""
  1. ;
  1. ;Update Date Updated
  1. S BQITMP(".09")=DT
  1. ;
  1. ;File Record Data
  1. M BQIDATA(FILE,FHRIEN_",")=BQITMP
  1. I $D(BQIDATA)>0 D FILE^DIE("","BQIDATA","ERROR")
  1. S RESULT=1_U_U_FHRIEN
  1. I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
  1. S BQII=BQII+1,@DATA@(BQII)=RESULT_$C(30)
  1. ;
  1. DONER ;
  1. S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1. Q
  1. ;
  1. NEWFR ;Create FAMILY HISTORY FAMILY MEMBERS record
  1. NEW DIC,DA,DR,X,Y
  1. I $G(FHRREL)="" S BMXSEC="RELATIONSHIP value is required" Q
  1. S DIC="^AUPNFHR(",DIC(0)="L",X=FHRREL,DIC("DR")=".02////"_DFN_";.11////^S X=DT;.09////^S X=DT"
  1. K DO,DD D FILE^DICN
  1. S FHRIEN=+Y
  1. I 'FHRIEN S BMXSEC="Unable to create new FAMILY HISTORY FAMILY MEMBERS RECORD"
  1. Q
  1. ;
  1. UPDC(DATA,DFN,TYPE,FHRIEN,FHCIEN,PARMS) ; EP - BQI UPDATE FAM HIST CONDITIONS
  1. ;Input
  1. ; DFN - Patient internal entry number
  1. ; TYPE - 'A' to add/edit or 'D' to delete ('E' gets converted to 'A')
  1. ; FHRIEN - FAMILY HISTORY FAMILY MEMBER IEN (Required for Add/Edit)
  1. ; FHCIEN - FAMILY HISTORY IEN (Required for Edit/Delete)
  1. ; PARMS - Data values
  1. ;
  1. NEW UID,BQ,BQIDATA,BQII,BQITMP,ERROR,FILE,MSG,RESULT,VFIEN
  1. NEW FHCDX,FHCNAR,FHCPRV,FHCAAO,FHCDTN,APCDTNQ
  1. ;
  1. S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1. S DATA=$NA(^TMP("BQIPTFHE",UID))
  1. K @DATA
  1. ;
  1. S BQII=0
  1. ;
  1. NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHE D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1. ;
  1. S @DATA@(BQII)="I00010RESULT^T01024MSG^I00010FHCIEN"_$C(30)
  1. ;
  1. S VFIEN=$O(^BQI(90506.3,"B","Family History Conditions",""))
  1. I VFIEN="" S BMXSEC="RPC Call Failed: Family History Conditions Definition does not exist." Q
  1. 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
  1. ;
  1. S DFN=$G(DFN,""),TYPE=$G(TYPE,""),FHRIEN=$G(FHRIEN,""),FHCIEN=$G(FHCIEN,"")
  1. I DFN="" S BMXSEC="Patient DFN value is required" Q
  1. ;
  1. ;Convert TYPE 'E' to 'A'
  1. S:TYPE="E" TYPE="A"
  1. ;
  1. I TYPE'="A",TYPE'="D" S BMXSEC="TYPE value is required (A-Add/Edit, D-Delete)" Q
  1. I TYPE="A",DFN="" S BMXSEC="Patient DFN value is required" Q
  1. I TYPE="A",FHRIEN="" S BMXSEC="Pointer to FAMILY HISTORY FAMILY MEMBERS is required" Q
  1. I TYPE="D",FHCIEN="" S BMXSEC="Pointer to FAMILY HISTORY is required for deletes"
  1. ;
  1. ;Handle Deletes
  1. I TYPE="D" D G DONEC
  1. . S RESULT=$$DELC(FHCIEN)
  1. . S BQII=BQII+1,@DATA@(BQII)=RESULT_$C(30)
  1. ;
  1. S PARMS=$G(PARMS,"")
  1. I PARMS="" D
  1. . N LIST,BN
  1. . S LIST="",BN=""
  1. . F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
  1. . K PARMS
  1. . S PARMS=LIST
  1. . K LIST
  1. ;
  1. ;Pull Parameter Data
  1. F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
  1. . N CHIEN,FIELD,NAME,PDATA,PFIEN,PTYP,VALUE
  1. . S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
  1. . S NAME=$P(PDATA,"=",1) I NAME="" Q
  1. . S VALUE=$P(PDATA,"=",2,99)
  1. . S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
  1. . I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
  1. . S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
  1. . I VALUE="",FIELD'=".001" S VALUE="@"
  1. . S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
  1. . I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
  1. . I PTYP="C" D
  1. .. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
  1. .. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
  1. . S @NAME=VALUE
  1. . I FIELD'=".001",FIELD]"" S BQITMP(FIELD)=VALUE
  1. ;
  1. ;Handle Adds
  1. I FHCIEN="" D NEWFC Q:$G(BMXSEC)'=""
  1. ;
  1. ;Special code to fill in Diagnosis Narrative (if blank)
  1. I $G(BQITMP(".04"))="",$G(BQITMP(".01"))]"" D
  1. . N TEXT
  1. . I $$VERSION^XPDUTL("BCSV") S TEXT=$P($$ICDDX^ICDCODE(BQITMP(".01"),DT),U,4)
  1. . I TEXT]"" D
  1. .. N DIC,DLAYGO,X,Y,IEN
  1. .. S DIC(0)="LX",DIC="^AUTNPOV(",DLAYGO=9999999.27,X=TEXT
  1. .. D ^DIC
  1. .. S IEN=+Y
  1. .. I IEN=-1 K DO,DD D FILE^DICN S TEXT=+Y
  1. . S BQITMP(".04")=TEXT ;Adapted from COND^APCDFH (APCD FAMILY HISTORY ADD/EDIT option)
  1. ;
  1. ;Update Relation IEN (Needed For Cases When Condition Gets Moved)
  1. S BQITMP(".09")=$G(FHRIEN)
  1. ;
  1. ;Update Date Last Modified
  1. S BQITMP(".12")=DT
  1. ;
  1. ;File Record Data
  1. M BQIDATA(FILE,FHCIEN_",")=BQITMP
  1. I $D(BQIDATA)>0 D FILE^DIE("","BQIDATA","ERROR")
  1. S RESULT=1_U_U_FHCIEN
  1. I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
  1. S BQII=BQII+1,@DATA@(BQII)=RESULT_$C(30)
  1. ;
  1. DONEC ;
  1. S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1. Q
  1. ;
  1. NEWFC ;Create FAMILY HISTORY record
  1. NEW DIC,DA,DR,X,Y
  1. I $G(FHCDX)="" S BMXSEC="CONDITION value is required" Q
  1. S DIC="^AUPNFH(",DIC(0)="L",X=FHCDX,DIC("DR")=".02////"_DFN_";.03////^S X=DT;.09////"_$G(FHRIEN)_";.12////^S X=DT"
  1. K DO,DD D FILE^DICN
  1. S FHCIEN=+Y
  1. I 'FHCIEN S BMXSEC="Unable to create new FAMILY HISTORY RECORD"
  1. Q
  1. ;
  1. DELR(FHRIEN) ;Delete a FAMILY HISTORY FAMILY MEMBERS record as well as any linked FAMILY HISTORY records
  1. ;
  1. NEW DIK,DA,RESULT
  1. ;
  1. I FHRIEN="" S RESULT=-1_U_"No FAMILY HISTORY FAMILY MEMBERS record passed in to delete" Q RESULT
  1. ;
  1. ;Verify that there are no linked conditions - If yes, cannot delete entry
  1. I $O(^AUPNFH("AE",FHRIEN,""))]"" S RESULT=-1_U_"This relation has conditions linked to it and cannot be deleted" Q RESULT
  1. ;
  1. ;Delete FAMILY HISTORY FAMILY MEMBERS record
  1. S RESULT=1_U
  1. S DIK="^AUPNFHR(",DA=FHRIEN D ^DIK
  1. Q RESULT
  1. ;
  1. DELC(FHCIEN) ;Delete a FAMILY HISTORY record
  1. ;
  1. NEW DIK,DA,RESULT
  1. ;
  1. I FHCIEN="" S RESULT=-1_U_"No FAMILY HISTORY record passed in to delete" Q RESULT
  1. ;
  1. S RESULT=1_U
  1. S DIK="^AUPNFH(",DA=FHCIEN D ^DIK
  1. Q RESULT