AGGPTADD ;VNGT/HS/ALA-Add new patient ; 19 Apr 2010 12:30 PM
;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
;
;
ADD(DATA,DEF,DFN,PARMS) ; EP - AGG ADD NEW PATIENT
; Input
; DEF = Mini Registration or New Patient
; DFN = if patient already created, null if new
; PARMS = Parameters
;
NEW UID,II,AGIEN,PDATA,FILE,LIST,NARRAY,BQ,NAME,VALUE,PFIEN,PTYP,CHIEN,AGI,AGJ,AGWP,PTNAME
NEW AGGPTLNM,AGGPTFNM,AGGPTMNM,AGGPTSFX,AGGPTSSN,AGGNOSSN,AGGPTHRN,AGGPTDOB,AGGPTSEX,AGGPTMAR
NEW EXEC,FIELD,TXT,FLAG,WDATA,FILE,SECFILE,AGGPTCOM,AGGPTCDT,ERROR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGPTADD",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGWDISP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S FLAG=0 I $G(DFN)="" S FLAG=1
S @DATA@(II)="I00010RESULT^T00080MESSAGE^I00010DFN"_$C(30)
S AGIEN=$$FIND1^DIC(9009068.3,"","BX",DEF,"","","ERROR")
I AGIEN=0 D Q
. S II=II+1,@DATA@(II)="-1^RPC Failed: Passed in window name "_DEF_" not found^"_$C(30)
. S II=II+1,@DATA@(II)=$C(31)
;
S FILE=$P(^AGG(9009068.3,AGIEN,0),U,2),SECFILE=$P(^AGG(9009068.3,AGIEN,0),U,14)
;
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
;
K NARRAY
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="@"
. 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="T" S VALUE=VALUE
. I PTYP="C"!(PTYP="K") 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" K AGGWP 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
. I NAME="AGGPTLNM" S NARRAY("FAMILY")=@NAME
. I NAME="AGGPTFNM" S NARRAY("GIVEN")=@NAME
. I NAME="AGGPTMNM" S NARRAY("MIDDLE")=@NAME
. I NAME="AGGPTSFX" S NARRAY("SUFFIX")=@NAME
;
F TXT="FAMILY","GIVEN","MIDDLE","SUFFIX" I $G(NARRAY(TXT))="" S NARRAY(TXT)=""
S PTNAME=$$F^XLFNAME1(.NARRAY,"C")
;
I $G(DFN)="" D
. NEW DIC,DLAYGO,DIADD,X,NWONE
. S X=PTNAME,DIC="^AUPNPAT(",DIC(0)="MLQ"
. D ^DIC
. S DFN=+Y,NWONE=$P(Y,U,3) I NWONE Q
. K AUPNPAT,AUPNDOB,AUPNDAYS,AUPNDOD,AUPNSEX
. S DIC="^DPT("
. K DO,DD D FILE^DICN
. S DFN=+Y,NWONE=$P(Y,U,3)
. I NWONE S ^AUPNPAT(DFN,0)=DFN,^AUPNPAT("B",DFN,DFN)=""
;
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),SECFLD=$P($G(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,7)
. S EXEC=$G(^AGG(9009068.3,AGIEN,10,PFIEN,7))
. I EXEC'="" X EXEC Q
. I FIELD="",SECFLD="" Q
. S PTYP=$P($G(^AGG(9009068.3,AGIEN,10,PFIEN,1)),U,1)
. I PTYP="C"!(PTYP="K")!(PTYP="T") D Q
.. I FIELD'="" S AGGDATAI(FILE,DFN_",",FIELD)=@NAME Q
.. I SECFLD'="" S AGGDATAI(SECFILE,DFN_",",SECFLD)=@NAME
. I FIELD'="" S AGGDATA(FILE,DFN_",",FIELD)=@NAME Q
. I SECFLD'="" S AGGDATA(SECFILE,DFN_",",SECFLD)=@NAME
;
I $D(AGGWP) D
. NEW FL,FD,IENS,WFLAG
. 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 WFLAG="" I FL=9000001,FD=1301 S WFLAG="A"
.... I $D(WDATA) D WP^DIE(FL,IENS,FD,WFLAG,WDATA,"ERROR")
;
I $G(AGGPTSSN)'="" S AGGDATAI(9000001,DFN_",",.23)=$O(^AUTTSSN("B","P",""))
I $D(AGGDATA) D FILE^DIE("","AGGDATA","ERROR")
I $D(AGGDATAI) D FILE^DIE("I","AGGDATAI","ERROR")
K AGGDATA,AGGDATAI
;
; 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
;
; Set the Previous community history
I $G(AGGPTCDT)'="" D COMM(DFN,AGGPTCDT,AGGPTCOM)
;
K AGGWP,AGWP
S RESULT=1_U
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
I $P(RESULT,U,1)'=-1 S RESULT=1_U_U_DFN
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
; 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")
. I FLAG D
.. D ADD^AGGEXPRT(DFN)
.. S ^AGPATCH($$NOW^XLFDT(),DUZ(2),DFN)="NEW",$P(^AUPNPAT(DFN,0),U,11)=DUZ
. I 'FLAG D EDIT^AGGEXPRT(DFN)
;
S NAME=""
F S NAME=$O(^AGG(9009068.3,AGIEN,10,"AC",NAME)) Q:NAME="" K @NAME
K ERROR
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
NAME(AGGPTLNM,AGGPTFNM,AGGPTMNM,AGGPTSFX) ;EP
S NARRAY("FAMILY")=$G(AGGPTLNM)
S NARRAY("GIVEN")=$G(AGGPTFNM)
S NARRAY("MIDDLE")=$G(AGGPTMNM)
S NARRAY("SUFFIX")=$G(AGGPTSFX)
S NAME=$$F^XLFNAME1(.NARRAY,"C")
Q NAME
;
COMM(DFN,AGGPTCDT,AGGPTCOM) ;
NEW DIC,DA
I AGGPTCDT'?.N S AGGPTCDT=$$DATE^AGGUL1(AGGPTCDT)
S DIC("P")=9000001.51,DIC="^AUPNPAT("_DFN_",51,",DIC(0)="QML",(DINUM,X)=AGGPTCDT
S DA(1)=DFN,DIC("DR")=".02////"_DT_";.03////"_AGGPTCOM K DD,DO D FILE^DICN
Q
AGGPTADD ;VNGT/HS/ALA-Add new patient ; 19 Apr 2010 12:30 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
+2 ;
+3 ;
ADD(DATA,DEF,DFN,PARMS) ; EP - AGG ADD NEW PATIENT
+1 ; Input
+2 ; DEF = Mini Registration or New Patient
+3 ; DFN = if patient already created, null if new
+4 ; PARMS = Parameters
+5 ;
+6 NEW UID,II,AGIEN,PDATA,FILE,LIST,NARRAY,BQ,NAME,VALUE,PFIEN,PTYP,CHIEN,AGI,AGJ,AGWP,PTNAME
+7 NEW AGGPTLNM,AGGPTFNM,AGGPTMNM,AGGPTSFX,AGGPTSSN,AGGNOSSN,AGGPTHRN,AGGPTDOB,AGGPTSEX,AGGPTMAR
+8 NEW EXEC,FIELD,TXT,FLAG,WDATA,FILE,SECFILE,AGGPTCOM,AGGPTCDT,ERROR
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("AGGPTADD",UID))
+11 KILL @DATA
+12 SET II=0
+13 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGWDISP D UNWIND^%ZTER"
+14 ;
+15 SET FLAG=0
IF $GET(DFN)=""
SET FLAG=1
+16 SET @DATA@(II)="I00010RESULT^T00080MESSAGE^I00010DFN"_$CHAR(30)
+17 SET AGIEN=$$FIND1^DIC(9009068.3,"","BX",DEF,"","","ERROR")
+18 IF AGIEN=0
Begin DoDot:1
+19 SET II=II+1
SET @DATA@(II)="-1^RPC Failed: Passed in window name "_DEF_" not found^"_$CHAR(30)
+20 SET II=II+1
SET @DATA@(II)=$CHAR(31)
End DoDot:1
QUIT
+21 ;
+22 SET FILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,2)
SET SECFILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,14)
+23 ;
+24 SET PARMS=$GET(PARMS,"")
+25 IF PARMS=""
Begin DoDot:1
+26 SET LIST=""
SET BN=""
+27 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+28 KILL PARMS
+29 SET PARMS=LIST
+30 KILL LIST
End DoDot:1
+31 ;
+32 KILL NARRAY
+33 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+34 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+35 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+36 ;I VALUE="" S VALUE="@"
+37 SET PFIEN=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME,""))
+38 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+39 SET PTYP=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,1)),U,1)
+40 IF PTYP="D"
SET VALUE=$$DATE^AGGUL1(VALUE)
+41 ;I PTYP="T" S VALUE=VALUE
+42 IF PTYP="C"!(PTYP="K")
Begin DoDot:2
+43 IF VALUE=""
QUIT
+44 SET CHIEN=$ORDER(^AGG(9009068.3,AGIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+45 SET VALUE=$PIECE(^AGG(9009068.3,AGIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+46 IF PTYP="W"
KILL AGGWP
Begin DoDot:2
+47 FOR AGI=1:1
SET AGJ=$PIECE(VALUE,$CHAR(10),AGI)
IF AGJ=""
QUIT
Begin DoDot:3
+48 SET AGWP(AGI,0)=$$CTRL^AGGUL1(AGJ)
End DoDot:3
End DoDot:2
QUIT
+49 SET @NAME=VALUE
+50 IF NAME="AGGPTLNM"
SET NARRAY("FAMILY")=@NAME
+51 IF NAME="AGGPTFNM"
SET NARRAY("GIVEN")=@NAME
+52 IF NAME="AGGPTMNM"
SET NARRAY("MIDDLE")=@NAME
+53 IF NAME="AGGPTSFX"
SET NARRAY("SUFFIX")=@NAME
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+54 ;
+55 FOR TXT="FAMILY","GIVEN","MIDDLE","SUFFIX"
IF $GET(NARRAY(TXT))=""
SET NARRAY(TXT)=""
+56 SET PTNAME=$$F^XLFNAME1(.NARRAY,"C")
+57 ;
+58 IF $GET(DFN)=""
Begin DoDot:1
+59 NEW DIC,DLAYGO,DIADD,X,NWONE
+60 SET X=PTNAME
SET DIC="^AUPNPAT("
SET DIC(0)="MLQ"
+61 DO ^DIC
+62 SET DFN=+Y
SET NWONE=$PIECE(Y,U,3)
IF NWONE
QUIT
+63 KILL AUPNPAT,AUPNDOB,AUPNDAYS,AUPNDOD,AUPNSEX
+64 SET DIC="^DPT("
+65 KILL DO,DD
DO FILE^DICN
+66 SET DFN=+Y
SET NWONE=$PIECE(Y,U,3)
+67 IF NWONE
SET ^AUPNPAT(DFN,0)=DFN
SET ^AUPNPAT("B",DFN,DFN)=""
End DoDot:1
+68 ;
+69 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+70 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+71 SET NAME=$PIECE(PDATA,"=",1)
+72 SET PFIEN=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME,""))
+73 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+74 SET FIELD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,1)
SET SECFLD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,7)
+75 SET EXEC=$GET(^AGG(9009068.3,AGIEN,10,PFIEN,7))
+76 IF EXEC'=""
XECUTE EXEC
QUIT
+77 IF FIELD=""
IF SECFLD=""
QUIT
+78 SET PTYP=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,1)),U,1)
+79 IF PTYP="C"!(PTYP="K")!(PTYP="T")
Begin DoDot:2
+80 IF FIELD'=""
SET AGGDATAI(FILE,DFN_",",FIELD)=@NAME
QUIT
+81 IF SECFLD'=""
SET AGGDATAI(SECFILE,DFN_",",SECFLD)=@NAME
End DoDot:2
QUIT
+82 IF FIELD'=""
SET AGGDATA(FILE,DFN_",",FIELD)=@NAME
QUIT
+83 IF SECFLD'=""
SET AGGDATA(SECFILE,DFN_",",SECFLD)=@NAME
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+84 ;
+85 IF $DATA(AGGWP)
Begin DoDot:1
+86 NEW FL,FD,IENS,WFLAG
+87 SET FL=""
+88 FOR
SET FL=$ORDER(AGGWP(FL))
IF FL=""
QUIT
Begin DoDot:2
+89 SET IENS=""
+90 FOR
SET IENS=$ORDER(AGGWP(FL,IENS))
IF IENS=""
QUIT
Begin DoDot:3
+91 SET FD=""
+92 FOR
SET FD=$ORDER(AGGWP(FL,IENS,FD))
IF FD=""
QUIT
Begin DoDot:4
+93 SET WFLAG=""
IF FL=9000001
IF FD=1301
SET WFLAG="A"
+94 IF $DATA(WDATA)
DO WP^DIE(FL,IENS,FD,WFLAG,WDATA,"ERROR")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+95 ;
+96 IF $GET(AGGPTSSN)'=""
SET AGGDATAI(9000001,DFN_",",.23)=$ORDER(^AUTTSSN("B","P",""))
+97 IF $DATA(AGGDATA)
DO FILE^DIE("","AGGDATA","ERROR")
+98 IF $DATA(AGGDATAI)
DO FILE^DIE("I","AGGDATAI","ERROR")
+99 KILL AGGDATA,AGGDATAI
+100 ;
+101 ; Set the HRN
+102 IF '$DATA(ERROR)
Begin DoDot:1
+103 NEW DIE,DR,DA
+104 IF $GET(AGGPTHRN)=""
QUIT
+105 SET DIE="^AUPNPAT("
SET DA=DFN
+106 SET DR="4101///"_"`"_DUZ(2)
+107 SET DR(2,9000001.41)=".02///"_AGGPTHRN
+108 DO ^DIE
End DoDot:1
+109 ;
+110 ; Set the Previous community history
+111 IF $GET(AGGPTCDT)'=""
DO COMM(DFN,AGGPTCDT,AGGPTCOM)
+112 ;
+113 KILL AGGWP,AGWP
+114 SET RESULT=1_U
+115 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+116 IF $PIECE(RESULT,U,1)'=-1
SET RESULT=1_U_U_DFN
+117 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+118 ;
+119 ; Set last date updated and updated by
+120 IF $PIECE(RESULT,U,1)=1
Begin DoDot:1
+121 SET AGGDATAI(9000001,DFN_",",.03)=DT
SET AGGDATAI(9000001,DFN_",",.12)=DUZ
+122 DO FILE^DIE("I","AGGDATAI","ERROR")
+123 IF FLAG
Begin DoDot:2
+124 DO ADD^AGGEXPRT(DFN)
+125 SET ^AGPATCH($$NOW^XLFDT(),DUZ(2),DFN)="NEW"
SET $PIECE(^AUPNPAT(DFN,0),U,11)=DUZ
End DoDot:2
+126 IF 'FLAG
DO EDIT^AGGEXPRT(DFN)
End DoDot:1
+127 ;
+128 SET NAME=""
+129 FOR
SET NAME=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME))
IF NAME=""
QUIT
KILL @NAME
+130 KILL ERROR
+131 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
NAME(AGGPTLNM,AGGPTFNM,AGGPTMNM,AGGPTSFX) ;EP
+1 SET NARRAY("FAMILY")=$GET(AGGPTLNM)
+2 SET NARRAY("GIVEN")=$GET(AGGPTFNM)
+3 SET NARRAY("MIDDLE")=$GET(AGGPTMNM)
+4 SET NARRAY("SUFFIX")=$GET(AGGPTSFX)
+5 SET NAME=$$F^XLFNAME1(.NARRAY,"C")
+6 QUIT NAME
+7 ;
COMM(DFN,AGGPTCDT,AGGPTCOM) ;
+1 NEW DIC,DA
+2 IF AGGPTCDT'?.N
SET AGGPTCDT=$$DATE^AGGUL1(AGGPTCDT)
+3 SET DIC("P")=9000001.51
SET DIC="^AUPNPAT("_DFN_",51,"
SET DIC(0)="QML"
SET (DINUM,X)=AGGPTCDT
+4 SET DA(1)=DFN
SET DIC("DR")=".02////"_DT_";.03////"_AGGPTCOM
KILL DD,DO
DO FILE^DICN
+5 QUIT
