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

BQIPTFHS.m

Go to the documentation of this file. 
  1. BQIPTFHS ;APTIV/HC/ALA-Patient Family History ; 02 Jan 2008  12:27 PM
  1.  ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
  1.  ;
  1.  Q
  1.  ;
  1. HIS(DATA,DFN) ; EP -- BQI PATIENT FAMILY HISTORY
  1.  ;
  1.  ;Description - all the family history that a patient has
  1.  ;
  1.  ;Input
  1.  ;  DFN - Patient internal entry number
  1.  ;
  1.  NEW UID,II,IEN,DIAG,NARR,RELAT,AGE,STAT,DTMNT,PROV,RELN,RELT,STC,STT,PRVR,PRVN,NIEN
  1.  NEW ARRAY,CIEN,RIEN,AGC,FHXDTLM,RORD,ORD,FHXRLTN,RELD,RELNM
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTFHS",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHS D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S @DATA@(II)="I00010FHXIEN^I00010FHXRIEN^T00060FHXRLTN^T00060FHXRLDS^T00060FHXDXN^T00080DXNARR^T00020FHXAGE^T00020FHXSTAT^D00030FHXDTNT^T00100APCDTNQ"_$C(30)
  1.  I $$VERSION^XPDUTL("BJPC")<2.0 D
  1.  . S IEN="",RIEN=""
  1.  . F  S IEN=$O(^AUPNFH("AC",DFN,IEN)) Q:IEN=""  D
  1.  .. S DIEN=$$GET1^DIQ(9000014,IEN_",",.01,"I") I DIEN="" Q
  1.  .. S DTMNT=$$GET1^DIQ(9000014,IEN_",",.03,"I")
  1.  .. I $$VERSION^XPDUTL("BCSV") S DIAG=$$ICD9^BQIUL3(DIEN,DTMNT,2)_"-"_$$ICD9^BQIUL3(DIEN,DTMNT,4) ; csv
  1.  .. I '$$VERSION^XPDUTL("BCSV") S DIAG=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")
  1.  .. S DIAG=DIEN_$C(28)_DIAG
  1.  .. ;S DIAG=$$GET1^DIQ(9000014,IEN_",",.01,"E") I DIAG="" Q
  1.  .. S NARR=$$GET1^DIQ(9000014,IEN_",",.04,"E")
  1.  .. S NIEN=$$GET1^DIQ(9000014,IEN_",",.04,"I")
  1.  .. I $$PATCH^XPDUTL("BJPC*2.0*10") S NARR=$$PNPROB^AUPNVUTL(NIEN)
  1.  .. S RELN=$$GET1^DIQ(9000014,IEN_",",.07,"I")
  1.  .. S RELT=$$GET1^DIQ(9000014,IEN_",",.07,"E")
  1.  .. S RELNM=RELT S:RELNM="" RELNM="~"
  1.  .. S RELAT="" I RELN'="" S RELAT=RELN_$C(28)_RELT
  1.  .. S AGE=$$GET1^DIQ(9000014,IEN_",",.05,"E")
  1.  .. S STC=$$GET1^DIQ(9000014,IEN_",",.06,"I")
  1.  .. S STT=$$GET1^DIQ(9000014,IEN_",",.06,"E")
  1.  .. S STAT="" I STC'="" S STAT=STC_$C(28)_STT
  1.  .. 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)
  1.  . S RELNM=""
  1.  . F  S RELNM=$O(ARRAY(RELNM)) Q:RELNM=""  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(ARRAY(RELNM,IEN)) Q:IEN=""  S II=II+1,@DATA@(II)=ARRAY(RELNM,IEN)
  1.  ;
  1.  I $$VERSION^XPDUTL("BJPC")>1.0 D
  1.  . NEW FAM,FREL
  1.  . S CIEN=""
  1.  . F  S CIEN=$O(^AUPNFH("AC",DFN,CIEN)) Q:CIEN=""  D
  1.  .. S DTMNT=$$GET1^DIQ(9000014,CIEN_",",.12,"I")
  1.  .. S DIEN=$$GET1^DIQ(9000014,CIEN_",",.01,"I") I DIEN="" Q
  1.  .. I $$VERSION^XPDUTL("BCSV") S DIAG=$$ICD9^BQIUL3(DIEN,DTMNT,2)_"-"_$$ICD9^BQIUL3(DIEN,DTMNT,4) ; csv
  1.  .. I '$$VERSION^XPDUTL("BCSV") S DIAG=$$GET1^DIQ(80,DIEN_",",.01,"E")_"-"_$$GET1^DIQ(80,DIEN_",",3,"E")
  1.  .. S DIAG=DIEN_$C(28)_DIAG
  1.  .. S NARR=$$GET1^DIQ(9000014,CIEN_",",.04,"E")
  1.  .. S NIEN=$$GET1^DIQ(9000014,CIEN_",",.04,"I")
  1.  .. S AGC=$$GET1^DIQ(9000014,CIEN_",",.11,"I")
  1.  .. S AGE="" I AGC'="" S AGE=AGC_$C(28)_$$GET1^DIQ(9000014,CIEN_",",.11,"E")
  1.  .. S RIEN=$$GET1^DIQ(9000014,CIEN_",",.09,"I")
  1.  .. I RIEN'="" S FAM(RIEN)=""
  1.  .. D GFAM
  1.  .. 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)
  1.  . ;
  1.  . S CIEN=""
  1.  . F  S CIEN=$O(^AUPNFHR("AA",DFN,CIEN)) Q:'CIEN  S RIEN="" D
  1.  .. F  S RIEN=$O(^AUPNFHR("AA",DFN,CIEN,RIEN)) Q:RIEN=""  D
  1.  ... I $D(FAM(RIEN)) Q
  1.  ... ; For family without diagnoses search FAMILY HISTORY FAMILY MEMBERS file
  1.  ... D GFAM
  1.  ... S ARRAY(RORD,RELNM,"R"_RIEN)=U_RIEN_U_RELAT_U_RELD_U_U_U_U_STAT_U_$$FMTE^BQIUL1(FHXDTLM)_U_$C(30)
  1.  . ;
  1.  . S ORD=""
  1.  . F  S ORD=$O(ARRAY(ORD)) Q:ORD=""  D
  1.  .. S RELNM=""
  1.  .. F  S RELNM=$O(ARRAY(ORD,RELNM)) Q:RELNM=""  D
  1.  ... S IEN=""
  1.  ... F  S IEN=$O(ARRAY(ORD,RELNM,IEN)) Q:IEN=""  S II=II+1,@DATA@(II)=ARRAY(ORD,RELNM,IEN)
  1.  S II=II+1,@DATA@(II)=$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(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. UPD(DATA,DFN,FHXIEN,FHXDXN,PARMS) ;EP - BQI UPDATE FAMILY HISTORY
  1.  ;Input
  1.  ;  DFN    - Patient internal entry number
  1.  ;  FHXIEN - Family History IEN if null create a new one
  1.  ;  if the FHXIEN is null then FHXDXN (the diagnosis) must be defined 
  1.  ;  PARMS  - Data values
  1.  ;
  1.  NEW UID,II,VFIEN,FILE,LIST,BN,BQ,PDATA,NAME,VALUE,PFIEN,PTYP,CHIEN,FIELD
  1.  NEW BQIDATA,ERROR,RESULT
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTFHU",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHS D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S @DATA@(II)="I00010RESULT^T001024ERROR"_$C(30)
  1.  ;
  1.  S FHXIEN=$G(FHXIEN,""),FHXDXN=$G(FHXDXN,"")
  1.  I FHXIEN=""&(FHXDXN="") S BMXSEC="RPC Call Failed: Needs diagnosis" Q
  1.  ;
  1.  ;if deleting a family history record
  1.  I FHXDXN="@" D DEL G DONE
  1.  ;
  1.  S VFIEN=$O(^BQI(90506.3,"B","Family History",""))
  1.  I VFIEN="" S BMXSEC="RPC Call Failed: Family History Definition does not exist." Q
  1.  S FILE=$P(^BQI(90506.3,VFIEN,0),U,2)
  1.  ;
  1.  S PARMS=$G(PARMS,"")
  1.  I PARMS="" D
  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.  I FHXIEN="" D NREC
  1.  ;
  1.  F BQ=1:1:$L(PARMS,$C(28)) D  Q:$G(BMXSEC)'=""
  1.  . S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
  1.  . S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99) I VALUE="" Q
  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 PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
  1.  . I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
  1.  . ;I PTYP="T" S VALUE=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 FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
  1.  . S BQIDATA(FILE,FHXIEN_",",FIELD)=VALUE
  1.  ;
  1.  K ERROR
  1.  I $D(BQIDATA)>0 D FILE^DIE("","BQIDATA","ERROR")
  1.  S RESULT=1_U
  1.  I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
  1.  S II=II+1,@DATA@(II)=RESULT_$C(30)
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. NREC ; Create new record
  1.  K DIC,DR,DA
  1.  NEW DIC,X,Y
  1.  S DIC="^AUPNFH(",DIC(0)="L",X=FHXDXN,DIC("DR")=".02////"_DFN_";.03////^S X=DT;.07////"_$G(FHXRLTN)
  1.  K DO,DD D FILE^DICN
  1.  S FHXIEN=+Y
  1.  Q
  1.  ;
  1. DEL ; Delete a record
  1.  NEW DIK,DA
  1.  S RESULT=1_U
  1.  S DIK="^AUPNFH("
  1.  I FHXIEN'="" S DA=FHXIEN D ^DIK
  1.  I FHXIEN="" S RESULT=-1_U_"No Family History record passed in to delete"
  1.  S II=II+1,@DATA@(II)=RESULT_$C(30)
  1.  Q
  1.  ;
  1. GFAM ; Get family history family members data
  1.  S RELN=$$GET1^DIQ(9000014.1,RIEN_",",.01,"I")
  1.  S RORD=$$GET1^DIQ(9999999.36,RELN_",",2103,"E") S:RORD="" RORD="~"
  1.  S RELT=$$GET1^DIQ(9000014.1,RIEN_",",.01,"E")
  1.  S RELNM=RELT S:RELNM="" RELNM="~"
  1.  S RELD=$$GET1^DIQ(9000014.1,RIEN_",",.03,"E")
  1.  S RELAT="" I RELN'="" S RELAT=RELN_$C(28)_RELT ;_" "_RELD
  1.  S STC=$$GET1^DIQ(9000014.1,RIEN_",",.04,"I")
  1.  S STT=$$GET1^DIQ(9000014.1,RIEN_",",.04,"E")
  1.  S STAT="" I STC'="" S STAT=STC_$C(28)_STT
  1.  S FHXDTLM=$$GET1^DIQ(9000014.1,RIEN_",",.09,"I")
  1.  Q