BQIPTUPD ;VNGT/HS/ALA-Update Patient Data ; 01 Dec 2008 12:22 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
;
UPD(DATA,DFN,PARMS) ; EP - BQI UPDATE PATIENT
NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC
NEW BQIDATA,ERROR,RESULT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTUPD",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTFHS D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T001024ERROR"_$C(30)
;
S VFIEN=$O(^BQI(90506.3,"B","Patient Edit",""))
I VFIEN="" S BMXSEC="RPC Call Failed: Patient Edit Definition does not exist." Q
S FILE=$P(^BQI(90506.3,VFIEN,0),U,2)
;
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 VALUE="" S VALUE="@"
. ;I VALUE="" Q
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
. I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
. ;I PTYP="T" S VALUE=VALUE
. I PTYP="C" D
.. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
. 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(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
. S EXEC=$G(^BQI(90506.3,VFIEN,10,PFIEN,7))
. I EXEC'="" X EXEC Q
. I FIELD="" Q
. S BQIDATA(FILE,DFN_",",FIELD)=@NAME
;
S RESULT=1_U
I $D(ERROR)>0 S RESULT=-1_U
K ERROR
I $D(BQIDATA)>0 D FILE^DIE("","BQIDATA","ERROR")
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
I $P(RESULT,U,1)'=-1 S RESULT=1_U
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
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="@" S RESULT=1_U Q
S 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,BQIRDA,RACE,MET
I $G(AGRMET)="" S MET="UNKNOWN"
; First delete the entry
S BQIRDA=0
F S BQIRDA=$O(^DPT(AGDFN,.02,BQIRDA)) Q:'BQIRDA D DRACE^AGAPIPAT(AGDFN,BQIRDA,.ERROR)
;
I 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
;
PFLG(AGDFN,AGLNG) ;EP - Update preferred language
NEW ERROR,RESULT,OK
I '$$PATCH^XPDUTL("AG*7.1*9") Q -1_U_"Patch AG*7.1*9 has not been installed"
S OK=$$PREF^AGAPIPAT(AGDFN,AGLNG)
I 'OK S RESULT=-1_U_$P(OK,U,2) Q
S RESULT=1_U
Q
;
PMETH(AGDFN,AGMETH) ;EP - Update preferred method
NEW ERROR,RESULT,OK
I '$$PATCH^XPDUTL("AG*7.1*9") Q -1_U_"Patch AG*7.1*9 has not been installed"
S OK=$$PMETH^AGAPIPAT(AGDFN,AGMETH)
I 'OK S RESULT=-1_U_$P(OK,U,2) Q
S RESULT=1_U
Q
;
EMAIL(AGDFN,AGEMAIL,AGUPDATE) ;EP - Update email address
NEW ERROR,RESULT,OK
S AGUPDATE=+$G(AGUPDATE)
I '$$PATCH^XPDUTL("AG*7.1*9") Q -1_U_"Patch AG*7.1*9 has not been installed"
S OK=$$EMAIL^AGAPIPAT(AGDFN,AGEMAIL,AGUPDATE)
I 'OK S RESULT=-1_U_$P(OK,U,2) Q
S RESULT=1_U
Q
;
RACE(DATA,DFN,TYPE,BQIRDA,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
; BQIRDA - 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("BQIPTRCE",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL 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,BQIRDA,.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
BQIPTUPD ;VNGT/HS/ALA-Update Patient Data ; 01 Dec 2008 12:22 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 ;
UPD(DATA,DFN,PARMS) ; EP - BQI UPDATE PATIENT
+1 NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC
+2 NEW BQIDATA,ERROR,RESULT
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIPTUPD",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTFHS D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010RESULT^T001024ERROR"_$CHAR(30)
+10 ;
+11 SET VFIEN=$ORDER(^BQI(90506.3,"B","Patient Edit",""))
+12 IF VFIEN=""
SET BMXSEC="RPC Call Failed: Patient Edit Definition does not exist."
QUIT
+13 SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
+14 ;
+15 SET PARMS=$GET(PARMS,"")
+16 IF PARMS=""
Begin DoDot:1
+17 SET LIST=""
SET BN=""
+18 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+19 KILL PARMS
+20 SET PARMS=LIST
+21 KILL LIST
End DoDot:1
+22 ;
+23 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+24 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+25 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+26 IF VALUE=""
SET VALUE="@"
+27 ;I VALUE="" Q
+28 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+29 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+30 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+31 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+32 ;I PTYP="T" S VALUE=VALUE
+33 IF PTYP="C"
Begin DoDot:2
+34 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+35 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+36 SET @NAME=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+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)
+41 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+42 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+43 SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+44 SET EXEC=$GET(^BQI(90506.3,VFIEN,10,PFIEN,7))
+45 IF EXEC'=""
XECUTE EXEC
QUIT
+46 IF FIELD=""
QUIT
+47 SET BQIDATA(FILE,DFN_",",FIELD)=@NAME
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+48 ;
+49 SET RESULT=1_U
+50 IF $DATA(ERROR)>0
SET RESULT=-1_U
+51 KILL ERROR
+52 IF $DATA(BQIDATA)>0
DO FILE^DIE("","BQIDATA","ERROR")
+53 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+54 IF $PIECE(RESULT,U,1)'=-1
SET RESULT=1_U
+55 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+56 ;
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="@"
SET RESULT=1_U
QUIT
+6 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,BQIRDA,RACE,MET
+2 IF $GET(AGRMET)=""
SET MET="UNKNOWN"
+3 ; First delete the entry
+4 SET BQIRDA=0
+5 FOR
SET BQIRDA=$ORDER(^DPT(AGDFN,.02,BQIRDA))
IF 'BQIRDA
QUIT
DO DRACE^AGAPIPAT(AGDFN,BQIRDA,.ERROR)
+6 ;
+7 IF 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 ;
PFLG(AGDFN,AGLNG) ;EP - Update preferred language
+1 NEW ERROR,RESULT,OK
+2 IF '$$PATCH^XPDUTL("AG*7.1*9")
QUIT -1_U_"Patch AG*7.1*9 has not been installed"
+3 SET OK=$$PREF^AGAPIPAT(AGDFN,AGLNG)
+4 IF 'OK
SET RESULT=-1_U_$PIECE(OK,U,2)
QUIT
+5 SET RESULT=1_U
+6 QUIT
+7 ;
PMETH(AGDFN,AGMETH) ;EP - Update preferred method
+1 NEW ERROR,RESULT,OK
+2 IF '$$PATCH^XPDUTL("AG*7.1*9")
QUIT -1_U_"Patch AG*7.1*9 has not been installed"
+3 SET OK=$$PMETH^AGAPIPAT(AGDFN,AGMETH)
+4 IF 'OK
SET RESULT=-1_U_$PIECE(OK,U,2)
QUIT
+5 SET RESULT=1_U
+6 QUIT
+7 ;
EMAIL(AGDFN,AGEMAIL,AGUPDATE) ;EP - Update email address
+1 NEW ERROR,RESULT,OK
+2 SET AGUPDATE=+$GET(AGUPDATE)
+3 IF '$$PATCH^XPDUTL("AG*7.1*9")
QUIT -1_U_"Patch AG*7.1*9 has not been installed"
+4 SET OK=$$EMAIL^AGAPIPAT(AGDFN,AGEMAIL,AGUPDATE)
+5 IF 'OK
SET RESULT=-1_U_$PIECE(OK,U,2)
QUIT
+6 SET RESULT=1_U
+7 QUIT
+8 ;
RACE(DATA,DFN,TYPE,BQIRDA,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 ; BQIRDA - 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("BQIPTRCE",UID))
+13 KILL @DATA
+14 ;
+15 SET II=0
+16 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL 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,BQIRDA,.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
