AGGMLUPD ;VNGT/HS/ALA-Multiple record update ; 20 May 2010 1:41 PM
;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
;
;
UPD(DATA,DEF,PROC,RIEN,MIEN,PARMS) ; EP - AGG UPDATE A MULTIPLE RECORD
; Input
; DEF - Definition Name
; RIEN - Record IEN
; MIEN - Multiple IEN
; PROC - 'A' to add, 'E' to edit, 'D' to delete
; PARMS - Parameters
;
NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC,GLBRT,SECFLD,BQ
NEW AGGDATA,ERROR,RESULT,AGGINT,IENS,X,DA,DIC,SUB,SECFILE,SUBFIL,SUBFLD,WHERE,NOD,REF
NEW PFIEN,Y
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"_$C(30)
;
S MIEN=$G(MIEN,"") S:MIEN=0 MIEN=""
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)
S SUB=$P(^AGG(9009068.3,VFIEN,0),U,7)
I SUB D
. S SUBFIL=$P(^AGG(9009068.3,VFIEN,0),U,10),SUBFLD=$P(^AGG(9009068.3,VFIEN,0),U,11)
. S WHERE=$P(^DD(SUBFIL,SUBFLD,0),U,4),REF=$P(^DD(SUBFIL,SUBFLD,0),U,2),NOD=$P(WHERE,";",1)
;
; Get previous data
I $G(RIEN)'="",$G(MIEN)'="" D
. S DA(1)=RIEN,DA=MIEN,IENS=$$IENS^DILF(.DA)
. 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,IENS,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,IENS,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 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)
. 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 $G(IENS)'="" D
.. I FIELD'="",$G(AGGINT(FILE,IENS,FIELD,"I"))'="",VALUE="" S VALUE="@"
.. I SECFLD'="",$G(AGGINT(SECFILE,IENS,SECFLD,"I"))'="",VALUE="" S VALUE="@"
. S @NAME=VALUE I FIELD=".01"!(SECFLD=".01") S X=VALUE
;
I PROC="D" D G FIN
. I FILE'="" S AGGDATA(FILE,IENS,.01)="@"
. I SECFILE'="" S AGGDATA(SECFILE,IENS,.01)="@"
. S RESULT=1
;
I $G(IENS)="",PROC="A" D I DA=-1 S RESULT="-1^"_"Unable to create new record" D PRB(RESULT) Q
. NEW DIC,DLAYGO
. S GLBRT=$$ROOT^DILFD(SUBFIL,"",0)
. S DIC(0)="L",DLAYGO="L",DA(1)=RIEN,DIC=GLBRT_DA(1)_","_NOD_","
. K DO,DD D FILE^DICN
. S DA=+Y I DA=-1 Q
. S IENS=$$IENS^DILF(.DA)
;
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 PTYP="C"!(PTYP="T")!(PTYP="K") D Q
.. I FIELD'="" S AGGDATAI(FILE,IENS,FIELD)=@NAME Q
.. I SECFLD'="" S AGGDATAI(SECFILE,IENS,SECFLD)=@NAME
. I FIELD'="" S AGGDATA(FILE,IENS,FIELD)=@NAME Q
. I SECFLD'="" S AGGDATA(SECFILE,IENS,SECFLD)=@NAME
;
S RESULT=1_U
;
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")
;
FIN ;
K AGGWP,AGWP
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
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))
I $P(RESULT,U,1)'=-1 S RESULT=1_U
S II=II+1,@DATA@(II)=RESULT_$C(30)
K AGGDATA,AGGDATAI
;
I $P(RESULT,U,1)=1 D
. I $G(DEF)="Other Tribe" D EDIT^AGGEXPRT(RIEN)
S NAME=""
F S NAME=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME)) Q:NAME="" I $G(@NAME)'="" K @NAME
;
DONE ;
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
;
PRB(RESULT) ;
S II=II+1,@DATA@(II)=RESULT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
AGGMLUPD ;VNGT/HS/ALA-Multiple record update ; 20 May 2010 1:41 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
+2 ;
+3 ;
UPD(DATA,DEF,PROC,RIEN,MIEN,PARMS) ; EP - AGG UPDATE A MULTIPLE RECORD
+1 ; Input
+2 ; DEF - Definition Name
+3 ; RIEN - Record IEN
+4 ; MIEN - Multiple IEN
+5 ; PROC - 'A' to add, 'E' to edit, 'D' to delete
+6 ; PARMS - Parameters
+7 ;
+8 NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC,GLBRT,SECFLD,BQ
+9 NEW AGGDATA,ERROR,RESULT,AGGINT,IENS,X,DA,DIC,SUB,SECFILE,SUBFIL,SUBFLD,WHERE,NOD,REF
+10 NEW PFIEN,Y
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("AGGPTUPD",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^T01024ERROR"_$CHAR(30)
+18 ;
+19 SET MIEN=$GET(MIEN,"")
IF MIEN=0
SET MIEN=""
+20 SET VFIEN=$ORDER(^AGG(9009068.3,"B",DEF,""))
+21 IF VFIEN=""
SET BMXSEC="RPC Call Failed: "_DEF_" Definition does not exist."
QUIT
+22 SET FILE=$PIECE(^AGG(9009068.3,VFIEN,0),U,2)
SET SECFILE=$PIECE(^AGG(9009068.3,VFIEN,0),U,14)
+23 SET SUB=$PIECE(^AGG(9009068.3,VFIEN,0),U,7)
+24 IF SUB
Begin DoDot:1
+25 SET SUBFIL=$PIECE(^AGG(9009068.3,VFIEN,0),U,10)
SET SUBFLD=$PIECE(^AGG(9009068.3,VFIEN,0),U,11)
+26 SET WHERE=$PIECE(^DD(SUBFIL,SUBFLD,0),U,4)
SET REF=$PIECE(^DD(SUBFIL,SUBFLD,0),U,2)
SET NOD=$PIECE(WHERE,";",1)
End DoDot:1
+27 ;
+28 ; Get previous data
+29 IF $GET(RIEN)'=""
IF $GET(MIEN)'=""
Begin DoDot:1
+30 SET DA(1)=RIEN
SET DA=MIEN
SET IENS=$$IENS^DILF(.DA)
+31 NEW FLD,LIST
+32 SET FLD=""
SET LIST=""
FOR
SET FLD=$ORDER(^AGG(9009068.3,VFIEN,10,"AD",FLD))
IF FLD=""
QUIT
SET LIST=LIST_FLD_";"
+33 SET LIST=$$TKO^AGGUL1(LIST,";")
+34 DO GETS^DIQ(FILE,IENS,LIST,"I","AGGINT")
+35 NEW FLD,LIST
+36 SET FLD=""
SET LIST=""
FOR
SET FLD=$ORDER(^AGG(9009068.3,VFIEN,10,"AG",FLD))
IF FLD=""
QUIT
SET LIST=LIST_FLD_";"
+37 DO GETS^DIQ(SECFILE,IENS,LIST,"I","AGGINT")
End DoDot:1
+38 ;
+39 SET PARMS=$GET(PARMS,"")
+40 IF PARMS=""
Begin DoDot:1
+41 SET LIST=""
SET BN=""
+42 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+43 KILL PARMS
+44 SET PARMS=LIST
+45 KILL LIST
End DoDot:1
+46 ;
+47 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+48 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+49 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+50 ;I VALUE="" S VALUE="@"
+51 ;I VALUE="" Q
+52 SET PFIEN=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
+53 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+54 SET PTYP=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
+55 IF PTYP="D"
SET VALUE=$$DATE^AGGUL1(VALUE)
+56 ;I PTYP="T" S VALUE=VALUE
+57 IF PTYP="C"!(PTYP="K")
Begin DoDot:2
+58 IF VALUE=""
QUIT
+59 SET CHIEN=$ORDER(^AGG(9009068.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+60 SET VALUE=$PIECE(^AGG(9009068.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+61 IF PTYP="W"
Begin DoDot:2
+62 FOR AGI=1:1
SET AGJ=$PIECE(VALUE,$CHAR(10),AGI)
IF AGJ=""
QUIT
Begin DoDot:3
+63 SET AGWP(AGI,0)=$$CTRL^AGGUL1(AGJ)
End DoDot:3
End DoDot:2
QUIT
+64 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)
+65 IF $GET(IENS)'=""
Begin DoDot:2
+66 IF FIELD'=""
IF $GET(AGGINT(FILE,IENS,FIELD,"I"))'=""
IF VALUE=""
SET VALUE="@"
+67 IF SECFLD'=""
IF $GET(AGGINT(SECFILE,IENS,SECFLD,"I"))'=""
IF VALUE=""
SET VALUE="@"
End DoDot:2
+68 SET @NAME=VALUE
IF FIELD=".01"!(SECFLD=".01")
SET X=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+69 ;
+70 IF PROC="D"
Begin DoDot:1
+71 IF FILE'=""
SET AGGDATA(FILE,IENS,.01)="@"
+72 IF SECFILE'=""
SET AGGDATA(SECFILE,IENS,.01)="@"
+73 SET RESULT=1
End DoDot:1
GOTO FIN
+74 ;
+75 IF $GET(IENS)=""
IF PROC="A"
Begin DoDot:1
+76 NEW DIC,DLAYGO
+77 SET GLBRT=$$ROOT^DILFD(SUBFIL,"",0)
+78 SET DIC(0)="L"
SET DLAYGO="L"
SET DA(1)=RIEN
SET DIC=GLBRT_DA(1)_","_NOD_","
+79 KILL DO,DD
DO FILE^DICN
+80 SET DA=+Y
IF DA=-1
QUIT
+81 SET IENS=$$IENS^DILF(.DA)
End DoDot:1
IF DA=-1
SET RESULT="-1^"_"Unable to create new record"
DO PRB(RESULT)
QUIT
+82 ;
+83 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+84 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+85 SET NAME=$PIECE(PDATA,"=",1)
+86 SET PFIEN=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
+87 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+88 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)
+89 SET EXEC=$GET(^AGG(9009068.3,VFIEN,10,PFIEN,7))
+90 IF EXEC'=""
XECUTE EXEC
QUIT
+91 IF FIELD=""
IF SECFLD=""
QUIT
+92 SET PTYP=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
+93 IF PTYP="C"!(PTYP="T")!(PTYP="K")
Begin DoDot:2
+94 IF FIELD'=""
SET AGGDATAI(FILE,IENS,FIELD)=@NAME
QUIT
+95 IF SECFLD'=""
SET AGGDATAI(SECFILE,IENS,SECFLD)=@NAME
End DoDot:2
QUIT
+96 IF FIELD'=""
SET AGGDATA(FILE,IENS,FIELD)=@NAME
QUIT
+97 IF SECFLD'=""
SET AGGDATA(SECFILE,IENS,SECFLD)=@NAME
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+98 ;
+99 SET RESULT=1_U
+100 ;
+101 IF $DATA(AGGWP)
Begin DoDot:1
+102 NEW FL,FD,IENS,FLAG
+103 SET FL=""
+104 FOR
SET FL=$ORDER(AGGWP(FL))
IF FL=""
QUIT
Begin DoDot:2
+105 SET IENS=""
+106 FOR
SET IENS=$ORDER(AGGWP(FL,IENS))
IF IENS=""
QUIT
Begin DoDot:3
+107 SET FD=""
+108 FOR
SET FD=$ORDER(AGGWP(FL,IENS,FD))
IF FD=""
QUIT
Begin DoDot:4
+109 SET FLAG=""
+110 ;I FL=9000001,FD=1301 S FLAG="A"
+111 IF $DATA(WDATA)
DO WP^DIE(FL,IENS,FD,FLAG,WDATA,"ERROR")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+112 ;
FIN ;
+1 KILL AGGWP,AGWP
+2 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+3 KILL ERROR
+4 IF $DATA(AGGDATA)>0
DO FILE^DIE("","AGGDATA","ERROR")
+5 IF $DATA(AGGDATAI)>0
DO FILE^DIE("I","AGGDATAI","ERROR")
+6 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+7 IF $PIECE(RESULT,U,1)'=-1
SET RESULT=1_U
+8 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+9 KILL AGGDATA,AGGDATAI
+10 ;
+11 IF $PIECE(RESULT,U,1)=1
Begin DoDot:1
+12 IF $GET(DEF)="Other Tribe"
DO EDIT^AGGEXPRT(RIEN)
End DoDot:1
+13 SET NAME=""
+14 FOR
SET NAME=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME))
IF NAME=""
QUIT
IF $GET(@NAME)'=""
KILL @NAME
+15 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
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 ;
PRB(RESULT) ;
+1 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+2 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+3 QUIT
