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

BQIPTUPD.m

Go to the documentation of this file. 
  1. BQIPTUPD ;VNGT/HS/ALA-Update Patient Data ; 01 Dec 2008  12:22 PM
  1.  ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
  1.  ;
  1.  ;
  1. UPD(DATA,DFN,PARMS) ; EP - BQI UPDATE PATIENT
  1.  NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC
  1.  NEW BQIDATA,ERROR,RESULT
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTUPD",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 VFIEN=$O(^BQI(90506.3,"B","Patient Edit",""))
  1.  I VFIEN="" S BMXSEC="RPC Call Failed: Patient Edit 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.  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)
  1.  . I VALUE="" S VALUE="@"
  1.  . ;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 @NAME=VALUE
  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)
  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.  . S EXEC=$G(^BQI(90506.3,VFIEN,10,PFIEN,7))
  1.  . I EXEC'="" X EXEC Q
  1.  . I FIELD="" Q
  1.  . S BQIDATA(FILE,DFN_",",FIELD)=@NAME
  1.  ;
  1.  S RESULT=1_U
  1.  I $D(ERROR)>0 S RESULT=-1_U
  1.  K ERROR
  1.  I $D(BQIDATA)>0 D FILE^DIE("","BQIDATA","ERROR")
  1.  I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
  1.  I $P(RESULT,U,1)'=-1 S RESULT=1_U
  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. ETHN(AGDFN,AGETH,AGMETH) ;EP - Update Ethnicity
  1.  NEW OK,ERROR
  1.  ; First delete the entry
  1.  S OK=$$DETH^AGAPIPAT(AGDFN,"",.ERROR)
  1.  ;I OK="ENTRY NOT FOUND" S OK=0
  1.  I AGETH="@" S RESULT=1_U Q
  1.  S AGMETH=$P(^DIC(10.3,AGMETH,0),U,1)
  1.  S AGETH=$P(^DIC(10.2,AGETH,0),U,1)
  1.  ; If no errors, OK=0, then add the new ethnicity
  1.  S OK=$$AETH^AGAPIPAT(AGDFN,AGETH,AGMETH,.ERROR)
  1.  I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1)) Q
  1.  S RESULT=1_U
  1.  Q
  1.  ;
  1. SRACE(AGDFN,AGRACE,AGRMET) ;EP - Update Race
  1.  NEW OK,ERROR,BQIRDA,RACE,MET
  1.  I $G(AGRMET)="" S MET="UNKNOWN"
  1.  ; First delete the entry
  1.  S BQIRDA=0
  1.  F  S BQIRDA=$O(^DPT(AGDFN,.02,BQIRDA)) Q:'BQIRDA  D DRACE^AGAPIPAT(AGDFN,BQIRDA,.ERROR)
  1.  ;
  1.  I AGRACE="@" S RESULT=1_U Q
  1.  S RACE=$P(^DIC(10,AGRACE,0),U,1)
  1.  ;S MET=$P(^DIC(10.3,AGRMET,0),U,1)
  1.  D ARACE^AGAPIPAT(AGDFN,RACE,MET,.ERROR)
  1.  ;
  1.  I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
  1.  S RESULT=1_U
  1.  Q
  1.  ;
  1. PFLG(AGDFN,AGLNG) ;EP - Update preferred language
  1.  NEW ERROR,RESULT,OK
  1.  I '$$PATCH^XPDUTL("AG*7.1*9") Q -1_U_"Patch AG*7.1*9 has not been installed"
  1.  S OK=$$PREF^AGAPIPAT(AGDFN,AGLNG)
  1.  I 'OK S RESULT=-1_U_$P(OK,U,2) Q
  1.  S RESULT=1_U
  1.  Q
  1.  ;
  1. PMETH(AGDFN,AGMETH) ;EP - Update preferred method
  1.  NEW ERROR,RESULT,OK
  1.  I '$$PATCH^XPDUTL("AG*7.1*9") Q -1_U_"Patch AG*7.1*9 has not been installed"
  1.  S OK=$$PMETH^AGAPIPAT(AGDFN,AGMETH)
  1.  I 'OK S RESULT=-1_U_$P(OK,U,2) Q
  1.  S RESULT=1_U
  1.  Q
  1.  ;
  1. EMAIL(AGDFN,AGEMAIL,AGUPDATE) ;EP - Update email address
  1.  NEW ERROR,RESULT,OK
  1.  S AGUPDATE=+$G(AGUPDATE)
  1.  I '$$PATCH^XPDUTL("AG*7.1*9") Q -1_U_"Patch AG*7.1*9 has not been installed"
  1.  S OK=$$EMAIL^AGAPIPAT(AGDFN,AGEMAIL,AGUPDATE)
  1.  I 'OK S RESULT=-1_U_$P(OK,U,2) Q
  1.  S RESULT=1_U
  1.  Q
  1.  ;
  1. RACE(DATA,DFN,TYPE,BQIRDA,AGRACE,AGRMET,PARMS) ; EP -- BQI UPDATE PAT RACE
  1.  ; Updates for multiple races
  1.  ;Input Parameters
  1.  ;  DFN    - Patient internal entry number
  1.  ;  TYPE   - 'A' to add or 'D' to delete
  1.  ;  BQIRDA - Race record IEN needed in order to delete
  1.  ;  AGRACE - Race value
  1.  ;  AGRMET - Method of Collection value
  1.  ;  PARMS  - List of parameters
  1.  ;  
  1.  NEW UID,II,ERROR,RESULT
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTRCE",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S @DATA@(II)="I00010RESULT^T01024MSG"_$C(30)
  1.  ;
  1.  S RESULT=1_U
  1.  ;
  1.  I TYPE="D" D DRACE^AGAPIPAT(DFN,BQIRDA,.ERROR)
  1.  ;
  1.  I TYPE="A" D
  1.  . NEW RACE,MET
  1.  . S RACE=$P(^DIC(10,AGRACE,0),U,1)
  1.  . S MET=$P(^DIC(10.3,AGRMET,0),U,1)
  1.  . D ARACE^AGAPIPAT(DFN,RACE,MET,.ERROR)
  1.  ;
  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.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q