AGGPTUPD ;VNGT/HS/ALA-Update Patient Data ; 16 Apr 2010 9:08 AM
;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
;
UPD(DATA,DEF,DFN,PARMS) ; EP - AGG UPDATE PATIENT
; Input
; DEF - Definition Name
; DFN - Patient IEN
; PARMS - Parameters
NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC,OTHPARM
NEW AGGDATA,ERROR,RESULT,AGGINT,WDATA,AGGPTEML
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGPTUPD",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024ERROR^T01024OTHER_PARMS"_$C(30)
;
S OTHPARM="" ;Initialize OTHER_PARMS return value
S VFIEN=$O(^AGG(9009068.3,"B",DEF,""))
I VFIEN="" S BMXSEC="RPC Call Failed: "_DEF_" Definition does not exist." Q
S FILE=$P(^AGG(9009068.3,VFIEN,0),U,2),SECFILE=$P(^AGG(9009068.3,VFIEN,0),U,14)
;
; Get previous data
NEW FLD,LIST
S FLD="",LIST="" F S FLD=$O(^AGG(9009068.3,VFIEN,10,"AD",FLD)) Q:FLD="" S LIST=LIST_FLD_";"
S LIST=$$TKO^AGGUL1(LIST,";")
D GETS^DIQ(FILE,DFN_",",LIST,"I","AGGINT")
;
NEW FLD,LIST
S FLD="",LIST="" F S FLD=$O(^AGG(9009068.3,VFIEN,10,"AG",FLD)) Q:FLD="" S LIST=LIST_FLD_";"
D GETS^DIQ(SECFILE,DFN_",",LIST,"I","AGGINT")
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I NAME="DFN",VALUE="" Q
. ;I VALUE="" S VALUE="@"
. ;I VALUE="" Q
. S PFIEN=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S PTYP=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
. I PTYP="D" S VALUE=$$DATE^AGGUL1(VALUE)
. ;I PTYP="T" S VALUE=VALUE
. I PTYP="C"!(PTYP="K") D
.. I VALUE="" Q
.. S CHIEN=$O(^AGG(9009068.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^AGG(9009068.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
. I PTYP="W" D Q
.. F AGI=1:1 S AGJ=$P(VALUE,$C(10),AGI) Q:AGJ="" D
... S AGWP(AGI,0)=$$CTRL^AGGUL1(AGJ)
. ;
. I $G(AGGPTCDT)'="" S AGGPTCDT=$$DATE^AGGUL1(AGGPTCDT)
. 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)
. I FIELD'="",$G(AGGINT(FILE,DFN_",",FIELD,"I"))'="",VALUE="" S VALUE="@"
. I SECFLD'="",$G(AGGINT(SECFILE,DFN_",",SECFLD,"I"))'="",VALUE="" S VALUE="@"
. ;I FIELD'="",$G(AGGINT(FILE,DFN_",",FIELD,"I"))'="",VALUE=$G(AGGINT(FILE,DFN_",",FIELD,"I")) Q
. ;I SECFLD'="",$G(AGGINT(SECFILE,DFN_",",SECFLD,"I"))'="",VALUE=$G(AGGINT(SECFILE,DFN_",",SECFLD,"I")) Q
. S @NAME=VALUE
;
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1)
. S PFIEN=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. 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)
. S EXEC=$G(^AGG(9009068.3,VFIEN,10,PFIEN,7))
. I EXEC'="" X EXEC Q
. I FIELD="",SECFLD="" Q
. S PTYP=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
. I NAME="AGGECREL"!(NAME="AGGNKREL")!(NAME="AGGPTVET") D Q
.. I FIELD'="" D HRDST(FILE,DFN,FIELD,@NAME) Q
.. I SECFLD'="" D HRDST(SECFILE,DFN,SECFLD,@NAME)
. I PTYP="C"!(PTYP="T")!(PTYP="K") D Q
.. I FIELD'="",$G(@NAME)'="",$G(@NAME)'=$G(AGGINT(FILE,DFN_",",FIELD,"I")) D Q
... I @NAME'="@" S AGGDATAI(FILE,DFN_",",FIELD)=@NAME Q
... S AGGDATA(FILE,DFN_",",FIELD)=@NAME
.. I SECFLD'="",$G(@NAME)'="",$G(@NAME)'=$G(AGGINT(SECFILE,DFN_",",SECFLD,"I")) D Q
... I @NAME'="@" S AGGDATAI(SECFILE,DFN_",",SECFLD)=@NAME Q
... S AGGDATA(SECFILE,DFN_",",SECFLD)=@NAME
. I FIELD'="",$G(@NAME)'="",$G(@NAME)'=$G(AGGINT(FILE,DFN_",",FIELD,"I")) S AGGDATA(FILE,DFN_",",FIELD)=@NAME Q
. I SECFLD'="",$G(@NAME)'="",$G(@NAME)'=$G(AGGINT(SECFILE,DFN_",",SECFLD,"I")) S AGGDATA(SECFILE,DFN_",",SECFLD)=@NAME
;
I $G(AGGPTCOM)'="" D
. S AGGDATA(9000001,DFN_",",1118)=$P(^AUTTCOM(AGGPTCOM,0),U,1)
. ; Set the Previous community history
. I $G(AGGPTCDT)'="" D COMM^AGGPTADD(DFN,AGGPTCDT,AGGPTCOM)
I $G(AGGPTEML)'="" D EML^AGGUL1(DFN)
;
; Set the HRN
I '$D(ERROR) D
. NEW DIE,DR,DA
. I $G(AGGPTHRN)="" Q
. S DIE="^AUPNPAT(",DA=DFN
. S DR="4101///"_"`"_DUZ(2)
. S DR(2,9000001.41)=".02///"_AGGPTHRN
. D ^DIE
;
S RESULT=1_U_U_$G(OTHPARM)
;
I $D(AGGWP) D
. NEW FL,FD,IENS,FLAG
. S FL=""
. F S FL=$O(AGGWP(FL)) Q:FL="" D
.. S IENS=""
.. F S IENS=$O(AGGWP(FL,IENS)) Q:IENS="" D
... S FD=""
... F S FD=$O(AGGWP(FL,IENS,FD)) Q:FD="" D
.... S FLAG=""
.... ;I FL=9000001,FD=1301 S FLAG="A"
.... I $D(WDATA) D WP^DIE(FL,IENS,FD,FLAG,WDATA,"ERROR")
;
K AGGWP,AGWP
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_U_$G(OTHPARM)
K ERROR
I $D(AGGDATA)>0 D FILE^DIE("","AGGDATA","ERROR")
I $D(AGGDATAI)>0 D FILE^DIE("I","AGGDATAI","ERROR")
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_U_$G(OTHPARM)
I $P(RESULT,U,1)'=-1 S RESULT=1_U_U_$G(OTHPARM)
;
; Set last date updated and updated by
I $P(RESULT,U,1)=1 D
. S AGGDATAI(9000001,DFN_",",.03)=DT,AGGDATAI(9000001,DFN_",",.12)=DUZ
. D FILE^DIE("I","AGGDATAI","ERROR")
. D EDIT^AGGEXPRT(DFN)
. I $$DECEASED^AGEDERR2(DFN) D ADDPAT^BIPATE(DFN,DUZ(2),,$P($G(^DPT(DFN,.35)),U),"d")
;
S II=II+1,@DATA@(II)=RESULT_$C(30)
K AGGDATA,AGGDATAI
S NAME=""
F S NAME=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME)) Q:NAME="" K @NAME
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
ETHN(AGDFN,AGETH,AGMETH) ;EP - Update Ethnicity
NEW OK,ERROR
; First delete the entry
S OK=$$DETH^AGAPIPAT(AGDFN,"",.ERROR)
;I OK="ENTRY NOT FOUND" S OK=0
I AGETH="@"!(AGETH="") S RESULT=1_U Q
S:AGMETH]"" AGMETH=$P(^DIC(10.3,AGMETH,0),U,1)
S AGETH=$P(^DIC(10.2,AGETH,0),U,1)
; If no errors, OK=0, then add the new ethnicity
S OK=$$AETH^AGAPIPAT(AGDFN,AGETH,AGMETH,.ERROR)
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1)) Q
S RESULT=1_U
Q
;
SRACE(AGDFN,AGRACE,AGRMET) ;EP - Update Race
NEW OK,ERROR,AGGRDA,RACE,MET
I $G(AGRMET)="" S MET="UNKNOWN"
; First delete the entry
S AGGRDA=0
F S AGGRDA=$O(^DPT(AGDFN,.02,AGGRDA)) Q:'AGGRDA D DRACE^AGAPIPAT(AGDFN,AGGRDA,.ERROR)
;
I AGRACE="@"!(AGRACE="") S RESULT=1_U Q
S RACE=$P(^DIC(10,AGRACE,0),U,1)
;S MET=$P(^DIC(10.3,AGRMET,0),U,1)
D ARACE^AGAPIPAT(AGDFN,RACE,MET,.ERROR)
;
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
S RESULT=1_U
Q
;
RACE(DATA,DFN,TYPE,AGGRDA,AGRACE,AGRMET,PARMS) ; EP -- BQI UPDATE PAT RACE
; Updates for multiple races
;Input Parameters
; DFN - Patient internal entry number
; TYPE - 'A' to add or 'D' to delete
; AGGRDA - Race record IEN needed in order to delete
; AGRACE - Race value
; AGRMET - Method of Collection value
; PARMS - List of parameters
;
NEW UID,II,ERROR,RESULT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGPTRCE",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024MSG"_$C(30)
;
S RESULT=1_U
;
I TYPE="D" D DRACE^AGAPIPAT(DFN,AGGRDA,.ERROR)
;
I TYPE="A" D
. NEW RACE,MET
. S RACE=$P(^DIC(10,AGRACE,0),U,1)
. S MET=$P(^DIC(10.3,AGRMET,0),U,1)
. D ARACE^AGAPIPAT(DFN,RACE,MET,.ERROR)
;
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
S II=II+1,@DATA@(II)=RESULT_$C(30)
S II=II+1,@DATA@(II)=$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(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
HRDST(FILE,DA,FIELD,VALUE) ; EP - Hard set data because they have triggers on them
NEW CROOT,WHERE,NOD,PEC
S CROOT=$$ROOT^DILFD(FILE,"",1)
S WHERE=$$GET1^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
I WHERE="" Q
S NOD=$P(WHERE,";",1),PEC=$P(WHERE,";",2)
S $P(@CROOT@(DA,NOD),U,PEC)=$S(VALUE'="@":VALUE,1:"")
Q
AGGPTUPD ;VNGT/HS/ALA-Update Patient Data ; 16 Apr 2010 9:08 AM
+1 ;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
+2 ;
UPD(DATA,DEF,DFN,PARMS) ; EP - AGG UPDATE PATIENT
+1 ; Input
+2 ; DEF - Definition Name
+3 ; DFN - Patient IEN
+4 ; PARMS - Parameters
+5 NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC,OTHPARM
+6 NEW AGGDATA,ERROR,RESULT,AGGINT,WDATA,AGGPTEML
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("AGGPTUPD",UID))
+9 KILL @DATA
+10 ;
+11 SET II=0
+12 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER"
+13 SET @DATA@(II)="I00010RESULT^T01024ERROR^T01024OTHER_PARMS"_$CHAR(30)
+14 ;
+15 ;Initialize OTHER_PARMS return value
SET OTHPARM=""
+16 SET VFIEN=$ORDER(^AGG(9009068.3,"B",DEF,""))
+17 IF VFIEN=""
SET BMXSEC="RPC Call Failed: "_DEF_" Definition does not exist."
QUIT
+18 SET FILE=$PIECE(^AGG(9009068.3,VFIEN,0),U,2)
SET SECFILE=$PIECE(^AGG(9009068.3,VFIEN,0),U,14)
+19 ;
+20 ; Get previous data
+21 NEW FLD,LIST
+22 SET FLD=""
SET LIST=""
FOR
SET FLD=$ORDER(^AGG(9009068.3,VFIEN,10,"AD",FLD))
IF FLD=""
QUIT
SET LIST=LIST_FLD_";"
+23 SET LIST=$$TKO^AGGUL1(LIST,";")
+24 DO GETS^DIQ(FILE,DFN_",",LIST,"I","AGGINT")
+25 ;
+26 NEW FLD,LIST
+27 SET FLD=""
SET LIST=""
FOR
SET FLD=$ORDER(^AGG(9009068.3,VFIEN,10,"AG",FLD))
IF FLD=""
QUIT
SET LIST=LIST_FLD_";"
+28 DO GETS^DIQ(SECFILE,DFN_",",LIST,"I","AGGINT")
+29 ;
+30 SET PARMS=$GET(PARMS,"")
+31 IF PARMS=""
Begin DoDot:1
+32 SET LIST=""
SET BN=""
+33 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+34 KILL PARMS
+35 SET PARMS=LIST
+36 KILL LIST
End DoDot:1
+37 ;
+38 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+39 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+40 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+41 IF NAME="DFN"
IF VALUE=""
QUIT
+42 ;I VALUE="" S VALUE="@"
+43 ;I VALUE="" Q
+44 SET PFIEN=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
+45 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+46 SET PTYP=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
+47 IF PTYP="D"
SET VALUE=$$DATE^AGGUL1(VALUE)
+48 ;I PTYP="T" S VALUE=VALUE
+49 IF PTYP="C"!(PTYP="K")
Begin DoDot:2
+50 IF VALUE=""
QUIT
+51 SET CHIEN=$ORDER(^AGG(9009068.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+52 SET VALUE=$PIECE(^AGG(9009068.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+53 IF PTYP="W"
Begin DoDot:2
+54 FOR AGI=1:1
SET AGJ=$PIECE(VALUE,$CHAR(10),AGI)
IF AGJ=""
QUIT
Begin DoDot:3
+55 SET AGWP(AGI,0)=$$CTRL^AGGUL1(AGJ)
End DoDot:3
End DoDot:2
QUIT
+56 ;
+57 IF $GET(AGGPTCDT)'=""
SET AGGPTCDT=$$DATE^AGGUL1(AGGPTCDT)
+58 SET FIELD=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,1)
SET SECFLD=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,7)
+59 IF FIELD'=""
IF $GET(AGGINT(FILE,DFN_",",FIELD,"I"))'=""
IF VALUE=""
SET VALUE="@"
+60 IF SECFLD'=""
IF $GET(AGGINT(SECFILE,DFN_",",SECFLD,"I"))'=""
IF VALUE=""
SET VALUE="@"
+61 ;I FIELD'="",$G(AGGINT(FILE,DFN_",",FIELD,"I"))'="",VALUE=$G(AGGINT(FILE,DFN_",",FIELD,"I")) Q
+62 ;I SECFLD'="",$G(AGGINT(SECFILE,DFN_",",SECFLD,"I"))'="",VALUE=$G(AGGINT(SECFILE,DFN_",",SECFLD,"I")) Q
+63 SET @NAME=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+64 ;
+65 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+66 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+67 SET NAME=$PIECE(PDATA,"=",1)
+68 SET PFIEN=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
+69 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+70 SET FIELD=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,1)
SET SECFLD=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,7)
+71 SET EXEC=$GET(^AGG(9009068.3,VFIEN,10,PFIEN,7))
+72 IF EXEC'=""
XECUTE EXEC
QUIT
+73 IF FIELD=""
IF SECFLD=""
QUIT
+74 SET PTYP=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
+75 IF NAME="AGGECREL"!(NAME="AGGNKREL")!(NAME="AGGPTVET")
Begin DoDot:2
+76 IF FIELD'=""
DO HRDST(FILE,DFN,FIELD,@NAME)
QUIT
+77 IF SECFLD'=""
DO HRDST(SECFILE,DFN,SECFLD,@NAME)
End DoDot:2
QUIT
+78 IF PTYP="C"!(PTYP="T")!(PTYP="K")
Begin DoDot:2
+79 IF FIELD'=""
IF $GET(@NAME)'=""
IF $GET(@NAME)'=$GET(AGGINT(FILE,DFN_",",FIELD,"I"))
Begin DoDot:3
+80 IF @NAME'="@"
SET AGGDATAI(FILE,DFN_",",FIELD)=@NAME
QUIT
+81 SET AGGDATA(FILE,DFN_",",FIELD)=@NAME
End DoDot:3
QUIT
+82 IF SECFLD'=""
IF $GET(@NAME)'=""
IF $GET(@NAME)'=$GET(AGGINT(SECFILE,DFN_",",SECFLD,"I"))
Begin DoDot:3
+83 IF @NAME'="@"
SET AGGDATAI(SECFILE,DFN_",",SECFLD)=@NAME
QUIT
+84 SET AGGDATA(SECFILE,DFN_",",SECFLD)=@NAME
End DoDot:3
QUIT
End DoDot:2
QUIT
+85 IF FIELD'=""
IF $GET(@NAME)'=""
IF $GET(@NAME)'=$GET(AGGINT(FILE,DFN_",",FIELD,"I"))
SET AGGDATA(FILE,DFN_",",FIELD)=@NAME
QUIT
+86 IF SECFLD'=""
IF $GET(@NAME)'=""
IF $GET(@NAME)'=$GET(AGGINT(SECFILE,DFN_",",SECFLD,"I"))
SET AGGDATA(SECFILE,DFN_",",SECFLD)=@NAME
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+87 ;
+88 IF $GET(AGGPTCOM)'=""
Begin DoDot:1
+89 SET AGGDATA(9000001,DFN_",",1118)=$PIECE(^AUTTCOM(AGGPTCOM,0),U,1)
+90 ; Set the Previous community history
+91 IF $GET(AGGPTCDT)'=""
DO COMM^AGGPTADD(DFN,AGGPTCDT,AGGPTCOM)
End DoDot:1
+92 IF $GET(AGGPTEML)'=""
DO EML^AGGUL1(DFN)
+93 ;
+94 ; Set the HRN
+95 IF '$DATA(ERROR)
Begin DoDot:1
+96 NEW DIE,DR,DA
+97 IF $GET(AGGPTHRN)=""
QUIT
+98 SET DIE="^AUPNPAT("
SET DA=DFN
+99 SET DR="4101///"_"`"_DUZ(2)
+100 SET DR(2,9000001.41)=".02///"_AGGPTHRN
+101 DO ^DIE
End DoDot:1
+102 ;
+103 SET RESULT=1_U_U_$GET(OTHPARM)
+104 ;
+105 IF $DATA(AGGWP)
Begin DoDot:1
+106 NEW FL,FD,IENS,FLAG
+107 SET FL=""
+108 FOR
SET FL=$ORDER(AGGWP(FL))
IF FL=""
QUIT
Begin DoDot:2
+109 SET IENS=""
+110 FOR
SET IENS=$ORDER(AGGWP(FL,IENS))
IF IENS=""
QUIT
Begin DoDot:3
+111 SET FD=""
+112 FOR
SET FD=$ORDER(AGGWP(FL,IENS,FD))
IF FD=""
QUIT
Begin DoDot:4
+113 SET FLAG=""
+114 ;I FL=9000001,FD=1301 S FLAG="A"
+115 IF $DATA(WDATA)
DO WP^DIE(FL,IENS,FD,FLAG,WDATA,"ERROR")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+116 ;
+117 KILL AGGWP,AGWP
+118 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))_U_$GET(OTHPARM)
+119 KILL ERROR
+120 IF $DATA(AGGDATA)>0
DO FILE^DIE("","AGGDATA","ERROR")
+121 IF $DATA(AGGDATAI)>0
DO FILE^DIE("I","AGGDATAI","ERROR")
+122 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))_U_$GET(OTHPARM)
+123 IF $PIECE(RESULT,U,1)'=-1
SET RESULT=1_U_U_$GET(OTHPARM)
+124 ;
+125 ; Set last date updated and updated by
+126 IF $PIECE(RESULT,U,1)=1
Begin DoDot:1
+127 SET AGGDATAI(9000001,DFN_",",.03)=DT
SET AGGDATAI(9000001,DFN_",",.12)=DUZ
+128 DO FILE^DIE("I","AGGDATAI","ERROR")
+129 DO EDIT^AGGEXPRT(DFN)
+130 IF $$DECEASED^AGEDERR2(DFN)
DO ADDPAT^BIPATE(DFN,DUZ(2),,$PIECE($GET(^DPT(DFN,.35)),U),"d")
End DoDot:1
+131 ;
+132 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+133 KILL AGGDATA,AGGDATAI
+134 SET NAME=""
+135 FOR
SET NAME=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME))
IF NAME=""
QUIT
KILL @NAME
+136 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
ETHN(AGDFN,AGETH,AGMETH) ;EP - Update Ethnicity
+1 NEW OK,ERROR
+2 ; First delete the entry
+3 SET OK=$$DETH^AGAPIPAT(AGDFN,"",.ERROR)
+4 ;I OK="ENTRY NOT FOUND" S OK=0
+5 IF AGETH="@"!(AGETH="")
SET RESULT=1_U
QUIT
+6 IF AGMETH]""
SET AGMETH=$PIECE(^DIC(10.3,AGMETH,0),U,1)
+7 SET AGETH=$PIECE(^DIC(10.2,AGETH,0),U,1)
+8 ; If no errors, OK=0, then add the new ethnicity
+9 SET OK=$$AETH^AGAPIPAT(AGDFN,AGETH,AGMETH,.ERROR)
+10 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
QUIT
+11 SET RESULT=1_U
+12 QUIT
+13 ;
SRACE(AGDFN,AGRACE,AGRMET) ;EP - Update Race
+1 NEW OK,ERROR,AGGRDA,RACE,MET
+2 IF $GET(AGRMET)=""
SET MET="UNKNOWN"
+3 ; First delete the entry
+4 SET AGGRDA=0
+5 FOR
SET AGGRDA=$ORDER(^DPT(AGDFN,.02,AGGRDA))
IF 'AGGRDA
QUIT
DO DRACE^AGAPIPAT(AGDFN,AGGRDA,.ERROR)
+6 ;
+7 IF AGRACE="@"!(AGRACE="")
SET RESULT=1_U
QUIT
+8 SET RACE=$PIECE(^DIC(10,AGRACE,0),U,1)
+9 ;S MET=$P(^DIC(10.3,AGRMET,0),U,1)
+10 DO ARACE^AGAPIPAT(AGDFN,RACE,MET,.ERROR)
+11 ;
+12 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+13 SET RESULT=1_U
+14 QUIT
+15 ;
RACE(DATA,DFN,TYPE,AGGRDA,AGRACE,AGRMET,PARMS) ; EP -- BQI UPDATE PAT RACE
+1 ; Updates for multiple races
+2 ;Input Parameters
+3 ; DFN - Patient internal entry number
+4 ; TYPE - 'A' to add or 'D' to delete
+5 ; AGGRDA - Race record IEN needed in order to delete
+6 ; AGRACE - Race value
+7 ; AGRMET - Method of Collection value
+8 ; PARMS - List of parameters
+9 ;
+10 NEW UID,II,ERROR,RESULT
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("AGGPTRCE",UID))
+13 KILL @DATA
+14 ;
+15 SET II=0
+16 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER"
+17 SET @DATA@(II)="I00010RESULT^T01024MSG"_$CHAR(30)
+18 ;
+19 SET RESULT=1_U
+20 ;
+21 IF TYPE="D"
DO DRACE^AGAPIPAT(DFN,AGGRDA,.ERROR)
+22 ;
+23 IF TYPE="A"
Begin DoDot:1
+24 NEW RACE,MET
+25 SET RACE=$PIECE(^DIC(10,AGRACE,0),U,1)
+26 SET MET=$PIECE(^DIC(10.3,AGRMET,0),U,1)
+27 DO ARACE^AGAPIPAT(DFN,RACE,MET,.ERROR)
End DoDot:1
+28 ;
+29 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+30 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+31 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+32 QUIT
+33 ;
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(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
HRDST(FILE,DA,FIELD,VALUE) ; EP - Hard set data because they have triggers on them
+1 NEW CROOT,WHERE,NOD,PEC
+2 SET CROOT=$$ROOT^DILFD(FILE,"",1)
+3 SET WHERE=$$GET1^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
+4 IF WHERE=""
QUIT
+5 SET NOD=$PIECE(WHERE,";",1)
SET PEC=$PIECE(WHERE,";",2)
+6 SET $PIECE(@CROOT@(DA,NOD),U,PEC)=$SELECT(VALUE'="@":VALUE,1:"")
+7 QUIT
