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

AGGPTUPD.m

Go to the documentation of this file. 
  1. AGGPTUPD ;VNGT/HS/ALA-Update Patient Data ; 16 Apr 2010  9:08 AM
  1.  ;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
  1.  ;
  1. UPD(DATA,DEF,DFN,PARMS) ; EP - AGG UPDATE PATIENT
  1.  ; Input
  1.  ;   DEF   - Definition Name
  1.  ;   DFN   - Patient IEN
  1.  ;   PARMS - Parameters
  1.  NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC,OTHPARM
  1.  NEW AGGDATA,ERROR,RESULT,AGGINT,WDATA,AGGPTEML
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("AGGPTUPD",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S @DATA@(II)="I00010RESULT^T01024ERROR^T01024OTHER_PARMS"_$C(30)
  1.  ;
  1.  S OTHPARM=""  ;Initialize OTHER_PARMS return value
  1.  S VFIEN=$O(^AGG(9009068.3,"B",DEF,""))
  1.  I VFIEN="" S BMXSEC="RPC Call Failed: "_DEF_" Definition does not exist." Q
  1.  S FILE=$P(^AGG(9009068.3,VFIEN,0),U,2),SECFILE=$P(^AGG(9009068.3,VFIEN,0),U,14)
  1.  ;
  1.  ; Get previous data
  1.  NEW FLD,LIST
  1.  S FLD="",LIST="" F  S FLD=$O(^AGG(9009068.3,VFIEN,10,"AD",FLD)) Q:FLD=""  S LIST=LIST_FLD_";"
  1.  S LIST=$$TKO^AGGUL1(LIST,";")
  1.  D GETS^DIQ(FILE,DFN_",",LIST,"I","AGGINT")
  1.  ;
  1.  NEW FLD,LIST
  1.  S FLD="",LIST="" F  S FLD=$O(^AGG(9009068.3,VFIEN,10,"AG",FLD)) Q:FLD=""  S LIST=LIST_FLD_";"
  1.  D GETS^DIQ(SECFILE,DFN_",",LIST,"I","AGGINT")
  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 NAME="DFN",VALUE="" Q
  1.  . ;I VALUE="" S VALUE="@"
  1.  . ;I VALUE="" Q
  1.  . S PFIEN=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
  1.  . I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
  1.  . S PTYP=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
  1.  . I PTYP="D" S VALUE=$$DATE^AGGUL1(VALUE)
  1.  . ;I PTYP="T" S VALUE=VALUE
  1.  . I PTYP="C"!(PTYP="K") D
  1.  .. I VALUE="" Q
  1.  .. S CHIEN=$O(^AGG(9009068.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
  1.  .. S VALUE=$P(^AGG(9009068.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
  1.  . I PTYP="W" D  Q
  1.  .. F AGI=1:1  S AGJ=$P(VALUE,$C(10),AGI) Q:AGJ=""  D
  1.  ... S AGWP(AGI,0)=$$CTRL^AGGUL1(AGJ)
  1.  . ;
  1.  . I $G(AGGPTCDT)'="" S AGGPTCDT=$$DATE^AGGUL1(AGGPTCDT)
  1.  . S FIELD=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,1),SECFLD=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,7)
  1.  . I FIELD'="",$G(AGGINT(FILE,DFN_",",FIELD,"I"))'="",VALUE="" S VALUE="@"
  1.  . I SECFLD'="",$G(AGGINT(SECFILE,DFN_",",SECFLD,"I"))'="",VALUE="" S VALUE="@"
  1.  . ;I FIELD'="",$G(AGGINT(FILE,DFN_",",FIELD,"I"))'="",VALUE=$G(AGGINT(FILE,DFN_",",FIELD,"I")) Q
  1.  . ;I SECFLD'="",$G(AGGINT(SECFILE,DFN_",",SECFLD,"I"))'="",VALUE=$G(AGGINT(SECFILE,DFN_",",SECFLD,"I")) Q
  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(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
  1.  . I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
  1.  . S FIELD=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,1),SECFLD=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,7)
  1.  . S EXEC=$G(^AGG(9009068.3,VFIEN,10,PFIEN,7))
  1.  . I EXEC'="" X EXEC Q
  1.  . I FIELD="",SECFLD="" Q
  1.  . S PTYP=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
  1.  . I NAME="AGGECREL"!(NAME="AGGNKREL")!(NAME="AGGPTVET") D  Q
  1.  .. I FIELD'="" D HRDST(FILE,DFN,FIELD,@NAME) Q
  1.  .. I SECFLD'="" D HRDST(SECFILE,DFN,SECFLD,@NAME)
  1.  . I PTYP="C"!(PTYP="T")!(PTYP="K") D  Q
  1.  .. I FIELD'="",$G(@NAME)'="",$G(@NAME)'=$G(AGGINT(FILE,DFN_",",FIELD,"I")) D  Q
  1.  ... I @NAME'="@" S AGGDATAI(FILE,DFN_",",FIELD)=@NAME Q
  1.  ... S AGGDATA(FILE,DFN_",",FIELD)=@NAME
  1.  .. I SECFLD'="",$G(@NAME)'="",$G(@NAME)'=$G(AGGINT(SECFILE,DFN_",",SECFLD,"I")) D  Q
  1.  ... I @NAME'="@" S AGGDATAI(SECFILE,DFN_",",SECFLD)=@NAME Q
  1.  ... S AGGDATA(SECFILE,DFN_",",SECFLD)=@NAME
  1.  . I FIELD'="",$G(@NAME)'="",$G(@NAME)'=$G(AGGINT(FILE,DFN_",",FIELD,"I")) S AGGDATA(FILE,DFN_",",FIELD)=@NAME Q
  1.  . I SECFLD'="",$G(@NAME)'="",$G(@NAME)'=$G(AGGINT(SECFILE,DFN_",",SECFLD,"I")) S AGGDATA(SECFILE,DFN_",",SECFLD)=@NAME
  1.  ;
  1.  I $G(AGGPTCOM)'="" D
  1.  . S AGGDATA(9000001,DFN_",",1118)=$P(^AUTTCOM(AGGPTCOM,0),U,1)
  1.  . ; Set the Previous community history
  1.  . I $G(AGGPTCDT)'="" D COMM^AGGPTADD(DFN,AGGPTCDT,AGGPTCOM)
  1.  I $G(AGGPTEML)'="" D EML^AGGUL1(DFN)
  1.  ;
  1.  ; Set the HRN
  1.  I '$D(ERROR) D
  1.  . NEW DIE,DR,DA
  1.  . I $G(AGGPTHRN)="" Q
  1.  . S DIE="^AUPNPAT(",DA=DFN
  1.  . S DR="4101///"_"`"_DUZ(2)
  1.  . S DR(2,9000001.41)=".02///"_AGGPTHRN
  1.  . D ^DIE
  1.  ;
  1.  S RESULT=1_U_U_$G(OTHPARM)
  1.  ;
  1.  I $D(AGGWP) D
  1.  . NEW FL,FD,IENS,FLAG
  1.  . S FL=""
  1.  . F  S FL=$O(AGGWP(FL)) Q:FL=""  D
  1.  .. S IENS=""
  1.  .. F  S IENS=$O(AGGWP(FL,IENS)) Q:IENS=""  D
  1.  ... S FD=""
  1.  ... F  S FD=$O(AGGWP(FL,IENS,FD)) Q:FD=""  D
  1.  .... S FLAG=""
  1.  .... ;I FL=9000001,FD=1301 S FLAG="A"
  1.  .... I $D(WDATA) D WP^DIE(FL,IENS,FD,FLAG,WDATA,"ERROR")
  1.  ;
  1.  K AGGWP,AGWP
  1.  I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_U_$G(OTHPARM)
  1.  K ERROR
  1.  I $D(AGGDATA)>0 D FILE^DIE("","AGGDATA","ERROR")
  1.  I $D(AGGDATAI)>0 D FILE^DIE("I","AGGDATAI","ERROR")
  1.  I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_U_$G(OTHPARM)
  1.  I $P(RESULT,U,1)'=-1 S RESULT=1_U_U_$G(OTHPARM)
  1.  ;
  1.  ; Set last date updated and updated by
  1.  I $P(RESULT,U,1)=1 D
  1.  . S AGGDATAI(9000001,DFN_",",.03)=DT,AGGDATAI(9000001,DFN_",",.12)=DUZ
  1.  . D FILE^DIE("I","AGGDATAI","ERROR")
  1.  . D EDIT^AGGEXPRT(DFN)
  1.  . I $$DECEASED^AGEDERR2(DFN) D ADDPAT^BIPATE(DFN,DUZ(2),,$P($G(^DPT(DFN,.35)),U),"d")
  1.  ;
  1.  S II=II+1,@DATA@(II)=RESULT_$C(30)
  1.  K AGGDATA,AGGDATAI
  1.  S NAME=""
  1.  F  S NAME=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME)) Q:NAME=""  K @NAME
  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="@"!(AGETH="") S RESULT=1_U Q
  1.  S:AGMETH]"" 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,AGGRDA,RACE,MET
  1.  I $G(AGRMET)="" S MET="UNKNOWN"
  1.  ; First delete the entry
  1.  S AGGRDA=0
  1.  F  S AGGRDA=$O(^DPT(AGDFN,.02,AGGRDA)) Q:'AGGRDA  D DRACE^AGAPIPAT(AGDFN,AGGRDA,.ERROR)
  1.  ;
  1.  I AGRACE="@"!(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. RACE(DATA,DFN,TYPE,AGGRDA,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.  ;  AGGRDA - 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("AGGPTRCE",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPTUPD 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,AGGRDA,.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
  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. HRDST(FILE,DA,FIELD,VALUE) ; EP - Hard set data because they have triggers on them
  1.  NEW CROOT,WHERE,NOD,PEC
  1.  S CROOT=$$ROOT^DILFD(FILE,"",1)
  1.  S WHERE=$$GET1^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
  1.  I WHERE="" Q
  1.  S NOD=$P(WHERE,";",1),PEC=$P(WHERE,";",2)
  1.  S $P(@CROOT@(DA,NOD),U,PEC)=$S(VALUE'="@":VALUE,1:"")
  1.  Q