AGGDCUPD ;VNGT/HS/ALA-Document Update ; 19 May 2010 3:32 PM
;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
;
;
UPD(DATA,DEF,DFN,PARMS) ; EP - AGG UPDATE DOCUMENTS
; Input
; DEF - Definition Name
; DFN - Patient IEN
; PARMS - Parameters
NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC,WDATA
NEW AGGDATA,ERROR,RESULT,AGGINT,PTYP,AGGPTRSI,AGGRHIDT,AGGRHIO,AGGRHTXT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGDCUPD",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 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)
;
I $G(^AUPNNPP(DFN,0))="" D NEWP
;
; 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 DA=$O(^AUPNRHI("B",DFN,""))
I DA'="" D
. S FLD="",LIST="" F S FLD=$O(^AGG(9009068.3,VFIEN,10,"AG",FLD)) Q:FLD="" S LIST=LIST_FLD_";"
. D GETS^DIQ(SECFILE,DA_",",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 FIELD'="",$G(AGGINT(FILE,DFN_",",FIELD,"I"))'="",VALUE="" S VALUE="@"
. I SECFLD'="",$G(AGGINT(SECFILE,DA_",",SECFLD,"I"))'="",VALUE="" S VALUE="@"
. 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 PTYP=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
. 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,DFN_",",FIELD)=@NAME Q
.. I SECFLD'="" S AGGDATAI(SECFILE,DA_",",SECFLD)=@NAME
. I FIELD'="" S AGGDATA(FILE,DFN_",",FIELD)=@NAME Q
. I SECFLD'="" S AGGDATA(SECFILE,DA_",",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")
;
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)
;
I $P(RESULT,U,1)=1 D
. S AGGDATAI(9000001,DFN_",",.03)=DT,AGGDATAI(9000001,DFN_",",.12)=DUZ
. D FILE^DIE("","AGGDATAI","ERROR")
. D EDIT^AGGEXPRT(DFN)
;
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
;
NEWP ;
NEW DIC,DLAYGO,Y,X,DINUM
S DIC="^AUPNNPP("
S DIC(0)="L"
S DLAYGO=9000038
;S X="`"_DFN
S (X,DINUM)=DFN
;D ^DIC
;I Y=-1 K DO,DD D FILE^DICN
K DO,DD D FILE^DICN
S DA=+Y
S AGGDATAI(FILE,DA_",",.06)=$$NOW^XLFDT()
S AGGDATAI(FILE,DA_",",.07)=DUZ
Q
;
NEWR ;
NEW DIC,DLAYGO,Y,X
S DIC="^AUPNRHI("
S DIC(0)="L"
S DLAYGO=9000039
S X=DFN
D ^DIC
I Y=-1 K DO,DD D FILE^DICN
S DA=+Y
Q
;
RHI ; EP
I $G(AGGPTRSI)="" Q
NEW FLD,DA,STAT
S DA=$O(^AUPNRHI("B",DFN,""))
I DA="" D NEWR
S DA=$O(^AUPNRHI("B",DFN,""))
S STAT=AGGPTRSI
S AGGDATA(9000039,DA_",",.03)=AGGPTRSI
S FLD=$S(STAT="P":.11,STAT="A":.21,STAT="R":.41,STAT="N":.31,1:"")
I $G(AGGRHIDT)="",FLD'="" S AGGDATAI(9000039,DA_",",FLD)=$$DT^XLFDT()
I $G(AGGRHIDT)'="",FLD'="" S AGGDATAI(9000039,DA_",",FLD)=AGGRHIDT
S FLD=$S(STAT="A":.22,STAT="R":.42,STAT="N":.32,1:"")
I $G(AGGRHIO)'="",FLD'="" S AGGDATA(9000039,DA_",",FLD)=AGGRHIO
I $G(AGGRHTXT)'="" S AGGDATA(9000039,DA_",",.02)=AGGRHTXT
S FLD=$S(STAT="P":.12,STAT="A":.23,STAT="R":.43,STAT="N":.33,STAT="E":.51,1:"")
I FLD'="" S AGGDATAI(9000039,DA_",",FLD)=DUZ
S FLD=$S(STAT="E":.52,STAT="P":.13,STAT="A":.24,STAT="R":.44,STAT="N":.34,1:"")
I FLD'="" S AGGDATAI(9000039,DA_",",FLD)=$$NOW^XLFDT()
Q
;
MRECU(DFN,AGGPTMRS) ; EP
I $G(AGGPTMRS)="" Q
I $G(DFN)="" Q
I $G(^AUPNPAT(DFN,41,DUZ(2),0))="" Q
NEW DA,IENS
S DA(1)=DFN,DA=DUZ(2),IENS=$$IENS^DILF(.DA)
S AGGDATAI(9000001.41,IENS,.04)=$G(AGGPTMRS)
Q
AGGDCUPD ;VNGT/HS/ALA-Document Update ; 19 May 2010 3:32 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
+2 ;
+3 ;
UPD(DATA,DEF,DFN,PARMS) ; EP - AGG UPDATE DOCUMENTS
+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,WDATA
+6 NEW AGGDATA,ERROR,RESULT,AGGINT,PTYP,AGGPTRSI,AGGRHIDT,AGGRHIO,AGGRHTXT
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("AGGDCUPD",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"_$CHAR(30)
+14 ;
+15 SET VFIEN=$ORDER(^AGG(9009068.3,"B",DEF,""))
+16 IF VFIEN=""
SET BMXSEC="RPC Call Failed: "_DEF_" Definition does not exist."
QUIT
+17 SET FILE=$PIECE(^AGG(9009068.3,VFIEN,0),U,2)
SET SECFILE=$PIECE(^AGG(9009068.3,VFIEN,0),U,14)
+18 ;
+19 IF $GET(^AUPNNPP(DFN,0))=""
DO NEWP
+20 ;
+21 ; Get previous data
+22 NEW FLD,LIST
+23 SET FLD=""
SET LIST=""
FOR
SET FLD=$ORDER(^AGG(9009068.3,VFIEN,10,"AD",FLD))
IF FLD=""
QUIT
SET LIST=LIST_FLD_";"
+24 SET LIST=$$TKO^AGGUL1(LIST,";")
+25 DO GETS^DIQ(FILE,DFN_",",LIST,"I","AGGINT")
+26 ;
+27 NEW FLD,LIST
+28 SET DA=$ORDER(^AUPNRHI("B",DFN,""))
+29 IF DA'=""
Begin DoDot:1
+30 SET FLD=""
SET LIST=""
FOR
SET FLD=$ORDER(^AGG(9009068.3,VFIEN,10,"AG",FLD))
IF FLD=""
QUIT
SET LIST=LIST_FLD_";"
+31 DO GETS^DIQ(SECFILE,DA_",",LIST,"I","AGGINT")
End DoDot:1
+32 ;
+33 SET PARMS=$GET(PARMS,"")
+34 IF PARMS=""
Begin DoDot:1
+35 SET LIST=""
SET BN=""
+36 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+37 KILL PARMS
+38 SET PARMS=LIST
+39 KILL LIST
End DoDot:1
+40 ;
+41 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+42 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+43 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+44 ;I VALUE="" S VALUE="@"
+45 ;I VALUE="" Q
+46 SET PFIEN=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
+47 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+48 SET PTYP=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
+49 IF PTYP="D"
SET VALUE=$$DATE^AGGUL1(VALUE)
+50 ;I PTYP="T" S VALUE=VALUE
+51 IF PTYP="C"!(PTYP="K")
Begin DoDot:2
+52 IF VALUE=""
QUIT
+53 SET CHIEN=$ORDER(^AGG(9009068.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+54 SET VALUE=$PIECE(^AGG(9009068.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+55 IF PTYP="W"
Begin DoDot:2
+56 FOR AGI=1:1
SET AGJ=$PIECE(VALUE,$CHAR(10),AGI)
IF AGJ=""
QUIT
Begin DoDot:3
+57 SET AGWP(AGI,0)=$$CTRL^AGGUL1(AGJ)
End DoDot:3
End DoDot:2
QUIT
+58 ;
+59 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)
+60 IF FIELD'=""
IF $GET(AGGINT(FILE,DFN_",",FIELD,"I"))'=""
IF VALUE=""
SET VALUE="@"
+61 IF SECFLD'=""
IF $GET(AGGINT(SECFILE,DA_",",SECFLD,"I"))'=""
IF VALUE=""
SET VALUE="@"
+62 SET @NAME=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+63 ;
+64 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+65 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+66 SET NAME=$PIECE(PDATA,"=",1)
+67 SET PFIEN=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
+68 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+69 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)
+70 SET PTYP=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
+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 PTYP="C"!(PTYP="T")!(PTYP="K")
Begin DoDot:2
+76 IF FIELD'=""
SET AGGDATAI(FILE,DFN_",",FIELD)=@NAME
QUIT
+77 IF SECFLD'=""
SET AGGDATAI(SECFILE,DA_",",SECFLD)=@NAME
End DoDot:2
QUIT
+78 IF FIELD'=""
SET AGGDATA(FILE,DFN_",",FIELD)=@NAME
QUIT
+79 IF SECFLD'=""
SET AGGDATA(SECFILE,DA_",",SECFLD)=@NAME
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+80 ;
+81 SET RESULT=1_U
+82 ;
+83 IF $DATA(AGGWP)
Begin DoDot:1
+84 NEW FL,FD,IENS,FLAG
+85 SET FL=""
+86 FOR
SET FL=$ORDER(AGGWP(FL))
IF FL=""
QUIT
Begin DoDot:2
+87 SET IENS=""
+88 FOR
SET IENS=$ORDER(AGGWP(FL,IENS))
IF IENS=""
QUIT
Begin DoDot:3
+89 SET FD=""
+90 FOR
SET FD=$ORDER(AGGWP(FL,IENS,FD))
IF FD=""
QUIT
Begin DoDot:4
+91 SET FLAG=""
+92 ;I FL=9000001,FD=1301 S FLAG="A"
+93 IF $DATA(WDATA)
DO WP^DIE(FL,IENS,FD,FLAG,WDATA,"ERROR")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+94 ;
+95 KILL AGGWP,AGWP
+96 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+97 KILL ERROR
+98 IF $DATA(AGGDATA)>0
DO FILE^DIE("","AGGDATA","ERROR")
+99 IF $DATA(AGGDATAI)>0
DO FILE^DIE("I","AGGDATAI","ERROR")
+100 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+101 IF $PIECE(RESULT,U,1)'=-1
SET RESULT=1_U
+102 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+103 ;
+104 IF $PIECE(RESULT,U,1)=1
Begin DoDot:1
+105 SET AGGDATAI(9000001,DFN_",",.03)=DT
SET AGGDATAI(9000001,DFN_",",.12)=DUZ
+106 DO FILE^DIE("","AGGDATAI","ERROR")
+107 DO EDIT^AGGEXPRT(DFN)
End DoDot:1
+108 ;
+109 KILL AGGDATA,AGGDATAI
+110 SET NAME=""
+111 FOR
SET NAME=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME))
IF NAME=""
QUIT
KILL @NAME
+112 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
NEWP ;
+1 NEW DIC,DLAYGO,Y,X,DINUM
+2 SET DIC="^AUPNNPP("
+3 SET DIC(0)="L"
+4 SET DLAYGO=9000038
+5 ;S X="`"_DFN
+6 SET (X,DINUM)=DFN
+7 ;D ^DIC
+8 ;I Y=-1 K DO,DD D FILE^DICN
+9 KILL DO,DD
DO FILE^DICN
+10 SET DA=+Y
+11 SET AGGDATAI(FILE,DA_",",.06)=$$NOW^XLFDT()
+12 SET AGGDATAI(FILE,DA_",",.07)=DUZ
+13 QUIT
+14 ;
NEWR ;
+1 NEW DIC,DLAYGO,Y,X
+2 SET DIC="^AUPNRHI("
+3 SET DIC(0)="L"
+4 SET DLAYGO=9000039
+5 SET X=DFN
+6 DO ^DIC
+7 IF Y=-1
KILL DO,DD
DO FILE^DICN
+8 SET DA=+Y
+9 QUIT
+10 ;
RHI ; EP
+1 IF $GET(AGGPTRSI)=""
QUIT
+2 NEW FLD,DA,STAT
+3 SET DA=$ORDER(^AUPNRHI("B",DFN,""))
+4 IF DA=""
DO NEWR
+5 SET DA=$ORDER(^AUPNRHI("B",DFN,""))
+6 SET STAT=AGGPTRSI
+7 SET AGGDATA(9000039,DA_",",.03)=AGGPTRSI
+8 SET FLD=$SELECT(STAT="P":.11,STAT="A":.21,STAT="R":.41,STAT="N":.31,1:"")
+9 IF $GET(AGGRHIDT)=""
IF FLD'=""
SET AGGDATAI(9000039,DA_",",FLD)=$$DT^XLFDT()
+10 IF $GET(AGGRHIDT)'=""
IF FLD'=""
SET AGGDATAI(9000039,DA_",",FLD)=AGGRHIDT
+11 SET FLD=$SELECT(STAT="A":.22,STAT="R":.42,STAT="N":.32,1:"")
+12 IF $GET(AGGRHIO)'=""
IF FLD'=""
SET AGGDATA(9000039,DA_",",FLD)=AGGRHIO
+13 IF $GET(AGGRHTXT)'=""
SET AGGDATA(9000039,DA_",",.02)=AGGRHTXT
+14 SET FLD=$SELECT(STAT="P":.12,STAT="A":.23,STAT="R":.43,STAT="N":.33,STAT="E":.51,1:"")
+15 IF FLD'=""
SET AGGDATAI(9000039,DA_",",FLD)=DUZ
+16 SET FLD=$SELECT(STAT="E":.52,STAT="P":.13,STAT="A":.24,STAT="R":.44,STAT="N":.34,1:"")
+17 IF FLD'=""
SET AGGDATAI(9000039,DA_",",FLD)=$$NOW^XLFDT()
+18 QUIT
+19 ;
MRECU(DFN,AGGPTMRS) ; EP
+1 IF $GET(AGGPTMRS)=""
QUIT
+2 IF $GET(DFN)=""
QUIT
+3 IF $GET(^AUPNPAT(DFN,41,DUZ(2),0))=""
QUIT
+4 NEW DA,IENS
+5 SET DA(1)=DFN
SET DA=DUZ(2)
SET IENS=$$IENS^DILF(.DA)
+6 SET AGGDATAI(9000001.41,IENS,.04)=$GET(AGGPTMRS)
+7 QUIT
