AGGPTNAM ;VNGT/HS/ALA-Patient Names ; 29 Jun 2010 3:27 PM
;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
;
ALIAS(DATA,DFN,PROC,RIEN,PARMS) ;EP -- AGG UPDATE ALIASES
NEW UID,II,BQ,PDATA,NAME,PFIEN,FIELD,EXEC,AGGDATA,AGGDATAI,PTYP,VALUE,CHIEN,AGI,AGWP
NEW X,Y,RESULT,DA,AGIEN,DIC,DLAYGO,IENS,ERROR,AGGPTALS
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGPTALIAS",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^I00010RIEN"_$C(30)
S AGIEN=$O(^AGG(9009068.3,"B","Aliases",""))
;if deleting an Alias
I $G(PROC)="D" D G DNE
. NEW DIK,DA
. S DA(1)=DFN,DA=RIEN
. S DIK="^DPT("_DA(1)_",.01," D ^DIK
;if adding a new Alias
D PARS
I $G(PROC)="A" D
. I $G(RIEN)="" D
.. I $G(^DPT(DFN,.01,0))="" S ^DPT(DFN,.01,0)="^2.01A^^"
.. S DA(1)=DFN
.. S DLAYGO=2.01,DIC(0)="L",DIC="^DPT("_DA(1)_",.01,",X=AGGPTALS
.. K DO,DD D FILE^DICN S RIEN=+Y
;if editing a Legal Name
S DA(1)=DFN,DA=RIEN,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,AGIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S FIELD=$P($G(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,1)
. S EXEC=$G(^AGG(9009068.3,AGIEN,10,PFIEN,7))
. I EXEC'="" X EXEC Q
. I FIELD="" Q
. S AGGDATA(2.01,IENS,FIELD)=@NAME
;
S AGGDATAI(9000001,DFN_",",.03)=DT,AGGDATAI(9000001,DFN_",",.12)=DUZ
I $D(AGGDATA) D FILE^DIE("","AGGDATA","ERROR")
I $D(AGGDATAI) D FILE^DIE("I","AGGDATAI","ERROR")
;
DNE ;
S RESULT=1_U_U_RIEN
I $D(ERROR) S RESULT="-1"_U_$G(ERROR("DIERR",1,"TEXT",1))_U_U
S II=II+1,@DATA@(II)=RESULT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
;
I $P(RESULT,U,1)=1 D EDIT^AGGEXPRT(DFN)
S NAME=""
F S NAME=$O(^AGG(9009068.3,AGIEN,10,"AC",NAME)) Q:NAME="" I $G(@NAME)'="" K @NAME
Q
;
LEGL(DATA,DFN,PROC,RIEN,PARMS) ;EP -- AGG UPDATE LEGAL NAMES
NEW UID,II,BQ,PDATA,NAME,PFIEN,FIELD,EXEC,AGGDATA,AGGDATAI,PTYP,VALUE,CHIEN,AGI,AGWP
NEW X,Y,RESULT,DA,AGIEN,DIC,DLAYGO,IENS,ERROR,AGGLNDTC
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGPTNAM",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^I00010RIEN"_$C(30)
S AGIEN=$O(^AGG(9009068.3,"B","Legal Names",""))
;
;if deleting a Legal Name
I $G(PROC)="D" D G DONE
. NEW DIK,DA
. S DIK="^AUPNNAMC(",DA=RIEN D ^DIK
;if adding a new Legal Name
D PARS
I $G(PROC)="A" D
. I $G(RIEN)="" D
.. I $G(AGGLNDTC)="" S AGGLNDTC=DT
.. S DLAYGO=9000033,DIC(0)="L",DIC="^AUPNNAMC(",X=AGGLNDTC
.. D ^DIC S RIEN=+Y
;if editing a Legal Name
S DA=RIEN,IENS=$$IENS^DILF(.DA)
;
S AGGDATAI(9000033,IENS,.02)=DFN
S AGGDATAI(9000033,IENS,.06)=DUZ
S AGGDATAI(9000001,DFN_",",.03)=DT,AGGDATAI(9000001,DFN_",",.12)=DUZ
;
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,AGIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S FIELD=$P($G(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,1)
. S EXEC=$G(^AGG(9009068.3,AGIEN,10,PFIEN,7))
. I EXEC'="" X EXEC Q
. I FIELD="" Q
. S AGGDATA(9000033,IENS,FIELD)=@NAME
I $D(AGGDATA) D FILE^DIE("","AGGDATA","ERROR")
I $D(AGGDATAI) D FILE^DIE("I","AGGDATAI","ERROR")
;
DONE ;
S RESULT=1_U_U_RIEN
I $D(ERROR) S RESULT="-1"_U_$G(ERROR("DIERR",1,"TEXT",1))_U_U
S II=II+1,@DATA@(II)=RESULT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
;
I $P(RESULT,U,1)=1 D EDIT^AGGEXPRT(DFN)
S NAME=""
F S NAME=$O(^AGG(9009068.3,AGIEN,10,"AC",NAME)) Q:NAME="" I $G(@NAME)'="" K @NAME
Q
;
PARS ;
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)
. S PFIEN=$O(^AGG(9009068.3,AGIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S PTYP=$P($G(^AGG(9009068.3,AGIEN,10,PFIEN,1)),U,1)
. I PTYP="D" S VALUE=$$DATE^AGGUL1(VALUE)
. I PTYP="C" D
.. I VALUE="" Q
.. S CHIEN=$O(^AGG(9009068.3,AGIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^AGG(9009068.3,AGIEN,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 @NAME=VALUE
Q
;
LINIT(DATA,PROC) ;EP -- AGG LEGAL NAME INIT TRIG
; Input
; PROC - Transaction type
;
NEW UID,II,VALUE,SOURCE,IEN,HELP,TYPE,ABLE,AGGECREL
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGLNMTR",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGWTRIG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
D HDR
S @DATA@(II)=HDR_$C(30)
I $G(PROC)="A" D
. S SOURCE="AGGLNPRF",VALUE="",ABLE="N",TYPE="X",CLEAR="",HELP="" D UP
. S SOURCE="AGGLGDOC",VALUE="",ABLE="N",TYPE="X",CLEAR="",HELP="" D UP
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
NMUP(DATA,AGGLNMC) ; EP -- AGG NAME CHANGE TRIG
NEW UID,II,VALUE,SOURCE,IEN,HELP,TYPE,ABLE,AGGECREL
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGLNMCTR",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGWTRIG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
D HDR
S @DATA@(II)=HDR_$C(30)
I $G(AGGLNMC)'="" D
. S SOURCE="AGGLNPRF",VALUE="",ABLE="Y",TYPE="X",CLEAR="",HELP="" D UP
. S SOURCE="AGGLGDOC",VALUE="",ABLE="Y",TYPE="X",CLEAR="",HELP="" D UP
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
UP ;
S II=II+1,@DATA@(II)=SOURCE_U_TYPE_U_VALUE_U_ABLE_U_$G(CLEAR)_U_HELP_$C(30)
Q
;
HDR ;
S HDR="T00008SOURCE^T00001CODE_TYPE^T01024PARMS^T00001ABLE_FLAG^T00100CLEAR_FIELDS^T00200HELP_TEXT"
Q
AGGPTNAM ;VNGT/HS/ALA-Patient Names ; 29 Jun 2010 3:27 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
+2 ;
ALIAS(DATA,DFN,PROC,RIEN,PARMS) ;EP -- AGG UPDATE ALIASES
+1 NEW UID,II,BQ,PDATA,NAME,PFIEN,FIELD,EXEC,AGGDATA,AGGDATAI,PTYP,VALUE,CHIEN,AGI,AGWP
+2 NEW X,Y,RESULT,DA,AGIEN,DIC,DLAYGO,IENS,ERROR,AGGPTALS
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("AGGPTALIAS",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010RESULT^T01024ERROR^I00010RIEN"_$CHAR(30)
+10 SET AGIEN=$ORDER(^AGG(9009068.3,"B","Aliases",""))
+11 ;if deleting an Alias
+12 IF $GET(PROC)="D"
Begin DoDot:1
+13 NEW DIK,DA
+14 SET DA(1)=DFN
SET DA=RIEN
+15 SET DIK="^DPT("_DA(1)_",.01,"
DO ^DIK
End DoDot:1
GOTO DNE
+16 ;if adding a new Alias
+17 DO PARS
+18 IF $GET(PROC)="A"
Begin DoDot:1
+19 IF $GET(RIEN)=""
Begin DoDot:2
+20 IF $GET(^DPT(DFN,.01,0))=""
SET ^DPT(DFN,.01,0)="^2.01A^^"
+21 SET DA(1)=DFN
+22 SET DLAYGO=2.01
SET DIC(0)="L"
SET DIC="^DPT("_DA(1)_",.01,"
SET X=AGGPTALS
+23 KILL DO,DD
DO FILE^DICN
SET RIEN=+Y
End DoDot:2
End DoDot:1
+24 ;if editing a Legal Name
+25 SET DA(1)=DFN
SET DA=RIEN
SET IENS=$$IENS^DILF(.DA)
+26 ;
+27 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+28 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+29 SET NAME=$PIECE(PDATA,"=",1)
+30 SET PFIEN=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME,""))
+31 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+32 SET FIELD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,1)
+33 SET EXEC=$GET(^AGG(9009068.3,AGIEN,10,PFIEN,7))
+34 IF EXEC'=""
XECUTE EXEC
QUIT
+35 IF FIELD=""
QUIT
+36 SET AGGDATA(2.01,IENS,FIELD)=@NAME
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+37 ;
+38 SET AGGDATAI(9000001,DFN_",",.03)=DT
SET AGGDATAI(9000001,DFN_",",.12)=DUZ
+39 IF $DATA(AGGDATA)
DO FILE^DIE("","AGGDATA","ERROR")
+40 IF $DATA(AGGDATAI)
DO FILE^DIE("I","AGGDATAI","ERROR")
+41 ;
DNE ;
+1 SET RESULT=1_U_U_RIEN
+2 IF $DATA(ERROR)
SET RESULT="-1"_U_$GET(ERROR("DIERR",1,"TEXT",1))_U_U
+3 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+4 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+5 ;
+6 IF $PIECE(RESULT,U,1)=1
DO EDIT^AGGEXPRT(DFN)
+7 SET NAME=""
+8 FOR
SET NAME=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME))
IF NAME=""
QUIT
IF $GET(@NAME)'=""
KILL @NAME
+9 QUIT
+10 ;
LEGL(DATA,DFN,PROC,RIEN,PARMS) ;EP -- AGG UPDATE LEGAL NAMES
+1 NEW UID,II,BQ,PDATA,NAME,PFIEN,FIELD,EXEC,AGGDATA,AGGDATAI,PTYP,VALUE,CHIEN,AGI,AGWP
+2 NEW X,Y,RESULT,DA,AGIEN,DIC,DLAYGO,IENS,ERROR,AGGLNDTC
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("AGGPTNAM",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010RESULT^T01024ERROR^I00010RIEN"_$CHAR(30)
+10 SET AGIEN=$ORDER(^AGG(9009068.3,"B","Legal Names",""))
+11 ;
+12 ;if deleting a Legal Name
+13 IF $GET(PROC)="D"
Begin DoDot:1
+14 NEW DIK,DA
+15 SET DIK="^AUPNNAMC("
SET DA=RIEN
DO ^DIK
End DoDot:1
GOTO DONE
+16 ;if adding a new Legal Name
+17 DO PARS
+18 IF $GET(PROC)="A"
Begin DoDot:1
+19 IF $GET(RIEN)=""
Begin DoDot:2
+20 IF $GET(AGGLNDTC)=""
SET AGGLNDTC=DT
+21 SET DLAYGO=9000033
SET DIC(0)="L"
SET DIC="^AUPNNAMC("
SET X=AGGLNDTC
+22 DO ^DIC
SET RIEN=+Y
End DoDot:2
End DoDot:1
+23 ;if editing a Legal Name
+24 SET DA=RIEN
SET IENS=$$IENS^DILF(.DA)
+25 ;
+26 SET AGGDATAI(9000033,IENS,.02)=DFN
+27 SET AGGDATAI(9000033,IENS,.06)=DUZ
+28 SET AGGDATAI(9000001,DFN_",",.03)=DT
SET AGGDATAI(9000001,DFN_",",.12)=DUZ
+29 ;
+30 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+31 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+32 SET NAME=$PIECE(PDATA,"=",1)
+33 SET PFIEN=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME,""))
+34 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+35 SET FIELD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,1)
+36 SET EXEC=$GET(^AGG(9009068.3,AGIEN,10,PFIEN,7))
+37 IF EXEC'=""
XECUTE EXEC
QUIT
+38 IF FIELD=""
QUIT
+39 SET AGGDATA(9000033,IENS,FIELD)=@NAME
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+40 IF $DATA(AGGDATA)
DO FILE^DIE("","AGGDATA","ERROR")
+41 IF $DATA(AGGDATAI)
DO FILE^DIE("I","AGGDATAI","ERROR")
+42 ;
DONE ;
+1 SET RESULT=1_U_U_RIEN
+2 IF $DATA(ERROR)
SET RESULT="-1"_U_$GET(ERROR("DIERR",1,"TEXT",1))_U_U
+3 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+4 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+5 ;
+6 IF $PIECE(RESULT,U,1)=1
DO EDIT^AGGEXPRT(DFN)
+7 SET NAME=""
+8 FOR
SET NAME=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME))
IF NAME=""
QUIT
IF $GET(@NAME)'=""
KILL @NAME
+9 QUIT
+10 ;
PARS ;
+1 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+2 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+3 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+4 SET PFIEN=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME,""))
+5 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+6 SET PTYP=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,1)),U,1)
+7 IF PTYP="D"
SET VALUE=$$DATE^AGGUL1(VALUE)
+8 IF PTYP="C"
Begin DoDot:2
+9 IF VALUE=""
QUIT
+10 SET CHIEN=$ORDER(^AGG(9009068.3,AGIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+11 SET VALUE=$PIECE(^AGG(9009068.3,AGIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+12 IF PTYP="W"
Begin DoDot:2
+13 FOR AGI=1:1
SET AGJ=$PIECE(VALUE,$CHAR(10),AGI)
IF AGJ=""
QUIT
Begin DoDot:3
+14 SET AGWP(AGI,0)=$$CTRL^AGGUL1(AGJ)
End DoDot:3
End DoDot:2
QUIT
+15 SET @NAME=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+16 QUIT
+17 ;
LINIT(DATA,PROC) ;EP -- AGG LEGAL NAME INIT TRIG
+1 ; Input
+2 ; PROC - Transaction type
+3 ;
+4 NEW UID,II,VALUE,SOURCE,IEN,HELP,TYPE,ABLE,AGGECREL
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("AGGLNMTR",UID))
+7 KILL @DATA
+8 SET II=0
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGWTRIG D UNWIND^%ZTER"
+10 DO HDR
+11 SET @DATA@(II)=HDR_$CHAR(30)
+12 IF $GET(PROC)="A"
Begin DoDot:1
+13 SET SOURCE="AGGLNPRF"
SET VALUE=""
SET ABLE="N"
SET TYPE="X"
SET CLEAR=""
SET HELP=""
DO UP
+14 SET SOURCE="AGGLGDOC"
SET VALUE=""
SET ABLE="N"
SET TYPE="X"
SET CLEAR=""
SET HELP=""
DO UP
End DoDot:1
+15 ;
+16 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+17 QUIT
+18 ;
NMUP(DATA,AGGLNMC) ; EP -- AGG NAME CHANGE TRIG
+1 NEW UID,II,VALUE,SOURCE,IEN,HELP,TYPE,ABLE,AGGECREL
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("AGGLNMCTR",UID))
+4 KILL @DATA
+5 SET II=0
+6 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGWTRIG D UNWIND^%ZTER"
+7 DO HDR
+8 SET @DATA@(II)=HDR_$CHAR(30)
+9 IF $GET(AGGLNMC)'=""
Begin DoDot:1
+10 SET SOURCE="AGGLNPRF"
SET VALUE=""
SET ABLE="Y"
SET TYPE="X"
SET CLEAR=""
SET HELP=""
DO UP
+11 SET SOURCE="AGGLGDOC"
SET VALUE=""
SET ABLE="Y"
SET TYPE="X"
SET CLEAR=""
SET HELP=""
DO UP
End DoDot:1
+12 ;
+13 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+14 QUIT
+15 ;
UP ;
+1 SET II=II+1
SET @DATA@(II)=SOURCE_U_TYPE_U_VALUE_U_ABLE_U_$GET(CLEAR)_U_HELP_$CHAR(30)
+2 QUIT
+3 ;
HDR ;
+1 SET HDR="T00008SOURCE^T00001CODE_TYPE^T01024PARMS^T00001ABLE_FLAG^T00100CLEAR_FIELDS^T00200HELP_TEXT"
+2 QUIT
