AGGPTDMG ;VNGT/HS/ALA-Patient Registration Special Updates ; 16 Apr 2010 9:08 AM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
;
MANY(DATA,DEF,XREF,DFN) ; EP -- AGG BUILD WINDOW MANY
; Input
; DEF - AGG Window Name
; XREF - Cross-reference ID for the patient (DFN)
; DFN - Patient IEN
; Description - Returns many records at a top level for one patient
;
NEW UID,II,AGIEN,AGCN,AGDATA,FLD,TYPE,CODE,DEXEC,ARRAY,AN,DQTY,VAL,VALUE,HEADR,HDATA,FILE,FL,FD
NEW VHD,J,K,LEN,LG,LN,ECHR,HDR,IEN,IENS
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGPTDMG",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 AGIEN=$$FIND1^DIC(9009068.3,"","BX",DEF,"","","ERROR")
I AGIEN=0 S BMXSEC="RPC Failed: Passed in window name "_DEF_" not found" Q
;
S FILE=$P(^AGG(9009068.3,AGIEN,0),U,2)
S GLBREF=$$ROOT^DILFD(FILE,"",1),RESULT=""
S IEN="",HEADR=""
F S IEN=$O(@GLBREF@(XREF,DFN,IEN)) Q:IEN="" D
. S HEADR="",HDATA="",IENS=IEN_","
. D REC(IENS)
. S @DATA@(0)=HEADR_$C(30)
. S II=II+1,@DATA@(II)=HDATA_$C(30)
I HEADR="" D
. D HDR
. S @DATA@(0)=HEADR_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
MUL(DATA,DEF,NOD,RIEN,MIEN) ; EP -- AGG BUILD WINDOW MULTIPLE
; Input
; DEF - AGG Window Name
; XREF - Cross-reference ID for the patient (DFN)
; RIEN - Record IEN (could be DFN)
; MIEN - Specific multiple IEN
; Description - Returns many records at a top level for one patient
;
NEW UID,II,AGIEN,AGCN,AGDATA,FLD,TYPE,CODE,DEXEC,ARRAY,AN,DQTY,VAL,VALUE,HEADR,HDATA,FILE,FL,FD
NEW VHD,J,K,LEN,LG,LN,ECHR,HDR,VAL1,VAL2,SBFIL
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGPTMUL",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 AGIEN=$$FIND1^DIC(9009068.3,"","BX",DEF,"","","ERROR")
I AGIEN=0 S BMXSEC="RPC Failed: Passed in window name "_DEF_" not found" Q
;
S FILE=$P(^AGG(9009068.3,AGIEN,0),U,2),SBFIL=$P(^AGG(9009068.3,AGIEN,0),U,10)
S GLBREF=$$ROOT^DILFD(SBFIL,"",1),RESULT="",HEADR=""
I $G(MIEN)'="" D Q
. S HEADR="",HDATA=""
. NEW DA,IENS
. S DA(1)=RIEN,DA=MIEN,IENS=$$IENS^DILF(.DA),IEN=MIEN
. D REC(IENS)
. S @DATA@(0)=HEADR_$C(30)
. S II=II+1,@DATA@(II)=HDATA_$C(30)
. S II=II+1,@DATA@(II)=$C(31)
;
S IEN=0
F S IEN=$O(@GLBREF@(RIEN,NOD,IEN)) Q:'IEN D
. S HEADR="",HDATA=""
. NEW DA,IENS
. S DA(1)=RIEN,DA=IEN,IENS=$$IENS^DILF(.DA)
. D REC(IENS)
. S @DATA@(0)=HEADR_$C(30)
. S II=II+1,@DATA@(II)=HDATA_$C(30)
I HEADR="" D
. D HDR
. S @DATA@(0)=HEADR_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
REC(IENS) ; Each Record
S AGCN=0
F S AGCN=$O(^AGG(9009068.3,AGIEN,10,AGCN)) Q:'AGCN D
. I $P(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'="" Q
. S AGDATA=$G(^AGG(9009068.3,AGIEN,10,AGCN,0))
. S FLD=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,1)
. S TYPE=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,1)),U,1)
. S CODE=$P(AGDATA,U,7),HDR=$P(AGDATA,U,2)
. S DEXEC=$G(^AGG(9009068.3,AGIEN,10,AGCN,8))
. I FLD="",DEXEC="" Q
. I TYPE="M" S VALUE=""
. I TYPE="T" D
.. I DEXEC'="" D Q
... S VAL=""
... S DQTY="I" X DEXEC S VAL=VALUE_$C(28)
... S DQTY="E" X DEXEC S VAL=VAL_VALUE
.. S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")_$C(28)_$$GET1^DIQ(FILE,IENS,FLD,"E")
. I (TYPE="C")!(TYPE="K") D
.. I DEXEC'="" D Q
... S VAL=""
... I DEXEC'["DQTY" X DEXEC Q
... S DQTY="I" X DEXEC S VAL=VALUE_$C(28)
... S DQTY="E" X DEXEC S VALUE=VAL_VALUE
.. I FLD'="" D Q
... S VAL1=$$GET1^DIQ(FILE,IENS,FLD,"I") I VAL1="" Q
... S VAL2=$O(^AGG(9009068.3,AGIEN,10,AGCN,5,"C",VAL1,"")) I VAL2="" Q
... S VAL2=$P(^AGG(9009068.3,AGIEN,10,AGCN,5,VAL2,0),U,1)
... S VALUE=VAL1_$C(28)_VAL2
.. S VAL1=$$GET1^DIQ(SECFILE,IENS,SECFLD,"I") I VAL1="" Q
.. S VAL2=$O(^AGG(9009068.3,AGIEN,10,AGCN,5,"C",VAL1,"")) I VAL2="" Q
.. S VAL2=$P(^AGG(9009068.3,AGIEN,10,AGCN,5,VAL2,0),U,1)
.. S VALUE=VAL1_$C(28)_VAL2
. I TYPE="X"!(TYPE="N") D
.. NEW TYPE
.. I DEXEC'="" X DEXEC Q
.. I FLD=.001 S VALUE=IEN Q
.. S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"E")
. I TYPE="D" D
.. I DEXEC'="" X DEXEC Q
.. S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I"),VALUE=$$FMTE^AGGUL1(VALUE)
. I TYPE="W" D
.. NEW FL,FD
.. K ARRAY S VALUE=""
.. I DEXEC'="" X DEXEC
.. I DEXEC="" D GETS^DIQ(FILE,IENS,FLD,"E","ARRAY")
.. S FL=$O(ARRAY("")) I FL="" Q
.. S FD=$O(ARRAY(FL,IENS,"")) I FD="" Q
.. S AN=0,TXT=ARRAY(FL,IENS,FD,"E") I TXT="" Q
.. K @TXT@("E")
.. F S AN=$O(@TXT@(AN)) Q:AN="" S VALUE=VALUE_@TXT@(AN)_$C(10)
. S HEADR=HEADR_HDR_"^"
. S HDATA=HDATA_VALUE_"^"
S HEADR=$$TKO^AGGUL1(HEADR,"^"),HDATA=$$TKO^AGGUL1(HDATA,"^")
Q
;
HDR ;
S AGCN=0
F S AGCN=$O(^AGG(9009068.3,AGIEN,10,AGCN)) Q:'AGCN D
. I $P(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'="" Q
. S HDR=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,0)),U,2)
. S HEADR=HEADR_HDR_"^"
S HEADR=$$TKO^AGGUL1(HEADR,"^")
Q
;
RACE(DATA,DFN) ; EP -- AGG PATIENT RACE
; Input
; DFN - Patients DFN or internal entry number
;
NEW UID,II,HDR,BN,RACE,METH
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGPTRCE",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 HDR="I00010AGGRDA^T00030AGRACE^T00030AGRMET"_$C(30)
S @DATA@(II)=HDR
S BN=0
F S BN=$O(^DPT(DFN,.02,BN)) Q:'BN D
. NEW DA,IENS
. S DA(1)=DFN,DA=BN,IENS=$$IENS^DILF(.DA)
. S RACE=$$GET1^DIQ(2.02,IENS,.01,"I")_$C(28)_$$GET1^DIQ(2.02,IENS,.01,"E")
. S METH=$$GET1^DIQ(2.02,IENS,.02,"I")_$C(28)_$$GET1^DIQ(2.02,IENS,.02,"E")
. S II=II+1,@DATA@(II)=BN_U_RACE_U_METH_$C(30)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
ETHN(DFN,FLD) ; EP - Patient's Ethnicity
NEW BN,VAL
S BN=0,VAL=""
F S BN=$O(^DPT(DFN,.06,BN)) Q:'BN D
. NEW DA,IENS
. S DA(1)=DFN,DA=BN,IENS=$$IENS^DILF(.DA)
. S VAL=$$GET1^DIQ(2.06,IENS,FLD,"I")_$C(28)_$$GET1^DIQ(2.06,IENS,FLD,"E")
Q VAL
;
RCE(DFN,FLD) ; EP - Patient's Race
NEW BN,VAL
S BN=0,VAL=""
F S BN=$O(^DPT(DFN,.02,BN)) Q:'BN D
. NEW DA,IENS
. S DA(1)=DFN,DA=BN,IENS=$$IENS^DILF(.DA)
. S VAL=$$GET1^DIQ(2.02,IENS,FLD,"I")_$C(28)_$$GET1^DIQ(2.02,IENS,FLD,"E")
Q VAL
;
SEQ(DEF,DFN) ;EP - Sequence number
NEW AGINSN1,AGINS,AGCAT,SEQ,QFL,AGN,INSNM,INSPTR
D EP^AGINS
D LOADCAT^AGCAT
S INSNM=$$UP^XLFSTR(DEF)
S INSPTR=$$FIND1^DIC(9999999.18,"","BX",INSNM,"","","ERROR")
I $G(RIEN)="" S RIEN=DFN
S SEQ="",QFL=0
F S SEQ=$O(AGINSNN(SEQ)) Q:SEQ="" D Q:QFL
. I $P($G(AGINSNN(SEQ)),U,2)=INSPTR,$P($G(AGINSNN(SEQ)),U,11)[RIEN S QFL=1 Q
. S AGN=""
. F S AGN=$O(AGINSNN(SEQ,AGN)) Q:AGN="" D Q:QFL
.. I $P(AGINSNN(SEQ,AGN),U,2)=INSPTR,$P(AGINSNN(SEQ,AGN),U,11)[RIEN S QFL=1
. I DEF="Private Insurance" S INSPTR=$$GET1^DIQ(9000006.11,IENS,.01,"I")
. I $P($G(AGINSNN(SEQ)),U,2)=INSPTR,$P($G(AGINSNN(SEQ)),U,11)[RIEN S QFL=1 Q
. S AGN=""
. F S AGN=$O(AGINSNN(SEQ,AGN)) Q:AGN="" D Q:QFL
.. I $P(AGINSNN(SEQ,AGN),U,2)=INSPTR,$P(AGINSNN(SEQ,AGN),U,11)[RIEN S QFL=1
K AGINSN1,AGINS,AGCAT,AGINSNN
Q SEQ
;
NEW SEQ,SFLD
S SEQ=""
S SFLD=$S(FILE=9000006.11:.01,1:.02)
S INSPTR=$$GET1^DIQ(FILE,IENS,SFLD,"I")
I $G(DFN)="" S DFN=RIEN
I '$D(^AUPNICP("C",DFN)) Q SEQ
S SIEN="",QFL=0
F S SIEN=$O(^AUPNICP("C",DFN,SIEN)) Q:SIEN=""!(QFL) D
. I $P(^AUPNICP(SIEN,0),U,14)'[IENS Q
. I $P(^AUPNICP(SIEN,0),U,3)=INSPTR S SEQ=$P(^AUPNICP(SIEN,0),U,5)
Q SEQ
AGGPTDMG ;VNGT/HS/ALA-Patient Registration Special Updates ; 16 Apr 2010 9:08 AM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
+3 ;
MANY(DATA,DEF,XREF,DFN) ; EP -- AGG BUILD WINDOW MANY
+1 ; Input
+2 ; DEF - AGG Window Name
+3 ; XREF - Cross-reference ID for the patient (DFN)
+4 ; DFN - Patient IEN
+5 ; Description - Returns many records at a top level for one patient
+6 ;
+7 NEW UID,II,AGIEN,AGCN,AGDATA,FLD,TYPE,CODE,DEXEC,ARRAY,AN,DQTY,VAL,VALUE,HEADR,HDATA,FILE,FL,FD
+8 NEW VHD,J,K,LEN,LG,LN,ECHR,HDR,IEN,IENS
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("AGGPTDMG",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 AGIEN=$$FIND1^DIC(9009068.3,"","BX",DEF,"","","ERROR")
+16 IF AGIEN=0
SET BMXSEC="RPC Failed: Passed in window name "_DEF_" not found"
QUIT
+17 ;
+18 SET FILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,2)
+19 SET GLBREF=$$ROOT^DILFD(FILE,"",1)
SET RESULT=""
+20 SET IEN=""
SET HEADR=""
+21 FOR
SET IEN=$ORDER(@GLBREF@(XREF,DFN,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+22 SET HEADR=""
SET HDATA=""
SET IENS=IEN_","
+23 DO REC(IENS)
+24 SET @DATA@(0)=HEADR_$CHAR(30)
+25 SET II=II+1
SET @DATA@(II)=HDATA_$CHAR(30)
End DoDot:1
+26 IF HEADR=""
Begin DoDot:1
+27 DO HDR
+28 SET @DATA@(0)=HEADR_$CHAR(30)
End DoDot:1
+29 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+30 QUIT
+31 ;
MUL(DATA,DEF,NOD,RIEN,MIEN) ; EP -- AGG BUILD WINDOW MULTIPLE
+1 ; Input
+2 ; DEF - AGG Window Name
+3 ; XREF - Cross-reference ID for the patient (DFN)
+4 ; RIEN - Record IEN (could be DFN)
+5 ; MIEN - Specific multiple IEN
+6 ; Description - Returns many records at a top level for one patient
+7 ;
+8 NEW UID,II,AGIEN,AGCN,AGDATA,FLD,TYPE,CODE,DEXEC,ARRAY,AN,DQTY,VAL,VALUE,HEADR,HDATA,FILE,FL,FD
+9 NEW VHD,J,K,LEN,LG,LN,ECHR,HDR,VAL1,VAL2,SBFIL
+10 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+11 SET DATA=$NAME(^TMP("AGGPTMUL",UID))
+12 KILL @DATA
+13 SET II=0
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGWDISP D UNWIND^%ZTER"
+15 ;
+16 SET AGIEN=$$FIND1^DIC(9009068.3,"","BX",DEF,"","","ERROR")
+17 IF AGIEN=0
SET BMXSEC="RPC Failed: Passed in window name "_DEF_" not found"
QUIT
+18 ;
+19 SET FILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,2)
SET SBFIL=$PIECE(^AGG(9009068.3,AGIEN,0),U,10)
+20 SET GLBREF=$$ROOT^DILFD(SBFIL,"",1)
SET RESULT=""
SET HEADR=""
+21 IF $GET(MIEN)'=""
Begin DoDot:1
+22 SET HEADR=""
SET HDATA=""
+23 NEW DA,IENS
+24 SET DA(1)=RIEN
SET DA=MIEN
SET IENS=$$IENS^DILF(.DA)
SET IEN=MIEN
+25 DO REC(IENS)
+26 SET @DATA@(0)=HEADR_$CHAR(30)
+27 SET II=II+1
SET @DATA@(II)=HDATA_$CHAR(30)
+28 SET II=II+1
SET @DATA@(II)=$CHAR(31)
End DoDot:1
QUIT
+29 ;
+30 SET IEN=0
+31 FOR
SET IEN=$ORDER(@GLBREF@(RIEN,NOD,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+32 SET HEADR=""
SET HDATA=""
+33 NEW DA,IENS
+34 SET DA(1)=RIEN
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+35 DO REC(IENS)
+36 SET @DATA@(0)=HEADR_$CHAR(30)
+37 SET II=II+1
SET @DATA@(II)=HDATA_$CHAR(30)
End DoDot:1
+38 IF HEADR=""
Begin DoDot:1
+39 DO HDR
+40 SET @DATA@(0)=HEADR_$CHAR(30)
End DoDot:1
+41 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+42 QUIT
+43 ;
REC(IENS) ; Each Record
+1 SET AGCN=0
+2 FOR
SET AGCN=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN))
IF 'AGCN
QUIT
Begin DoDot:1
+3 IF $PIECE(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'=""
QUIT
+4 SET AGDATA=$GET(^AGG(9009068.3,AGIEN,10,AGCN,0))
+5 SET FLD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,1)
+6 SET TYPE=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,1)),U,1)
+7 SET CODE=$PIECE(AGDATA,U,7)
SET HDR=$PIECE(AGDATA,U,2)
+8 SET DEXEC=$GET(^AGG(9009068.3,AGIEN,10,AGCN,8))
+9 IF FLD=""
IF DEXEC=""
QUIT
+10 IF TYPE="M"
SET VALUE=""
+11 IF TYPE="T"
Begin DoDot:2
+12 IF DEXEC'=""
Begin DoDot:3
+13 SET VAL=""
+14 SET DQTY="I"
XECUTE DEXEC
SET VAL=VALUE_$CHAR(28)
+15 SET DQTY="E"
XECUTE DEXEC
SET VAL=VAL_VALUE
End DoDot:3
QUIT
+16 SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")_$CHAR(28)_$$GET1^DIQ(FILE,IENS,FLD,"E")
End DoDot:2
+17 IF (TYPE="C")!(TYPE="K")
Begin DoDot:2
+18 IF DEXEC'=""
Begin DoDot:3
+19 SET VAL=""
+20 IF DEXEC'["DQTY"
XECUTE DEXEC
QUIT
+21 SET DQTY="I"
XECUTE DEXEC
SET VAL=VALUE_$CHAR(28)
+22 SET DQTY="E"
XECUTE DEXEC
SET VALUE=VAL_VALUE
End DoDot:3
QUIT
+23 IF FLD'=""
Begin DoDot:3
+24 SET VAL1=$$GET1^DIQ(FILE,IENS,FLD,"I")
IF VAL1=""
QUIT
+25 SET VAL2=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN,5,"C",VAL1,""))
IF VAL2=""
QUIT
+26 SET VAL2=$PIECE(^AGG(9009068.3,AGIEN,10,AGCN,5,VAL2,0),U,1)
+27 SET VALUE=VAL1_$CHAR(28)_VAL2
End DoDot:3
QUIT
+28 SET VAL1=$$GET1^DIQ(SECFILE,IENS,SECFLD,"I")
IF VAL1=""
QUIT
+29 SET VAL2=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN,5,"C",VAL1,""))
IF VAL2=""
QUIT
+30 SET VAL2=$PIECE(^AGG(9009068.3,AGIEN,10,AGCN,5,VAL2,0),U,1)
+31 SET VALUE=VAL1_$CHAR(28)_VAL2
End DoDot:2
+32 IF TYPE="X"!(TYPE="N")
Begin DoDot:2
+33 NEW TYPE
+34 IF DEXEC'=""
XECUTE DEXEC
QUIT
+35 IF FLD=.001
SET VALUE=IEN
QUIT
+36 SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"E")
End DoDot:2
+37 IF TYPE="D"
Begin DoDot:2
+38 IF DEXEC'=""
XECUTE DEXEC
QUIT
+39 SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")
SET VALUE=$$FMTE^AGGUL1(VALUE)
End DoDot:2
+40 IF TYPE="W"
Begin DoDot:2
+41 NEW FL,FD
+42 KILL ARRAY
SET VALUE=""
+43 IF DEXEC'=""
XECUTE DEXEC
+44 IF DEXEC=""
DO GETS^DIQ(FILE,IENS,FLD,"E","ARRAY")
+45 SET FL=$ORDER(ARRAY(""))
IF FL=""
QUIT
+46 SET FD=$ORDER(ARRAY(FL,IENS,""))
IF FD=""
QUIT
+47 SET AN=0
SET TXT=ARRAY(FL,IENS,FD,"E")
IF TXT=""
QUIT
+48 KILL @TXT@("E")
+49 FOR
SET AN=$ORDER(@TXT@(AN))
IF AN=""
QUIT
SET VALUE=VALUE_@TXT@(AN)_$CHAR(10)
End DoDot:2
+50 SET HEADR=HEADR_HDR_"^"
+51 SET HDATA=HDATA_VALUE_"^"
End DoDot:1
+52 SET HEADR=$$TKO^AGGUL1(HEADR,"^")
SET HDATA=$$TKO^AGGUL1(HDATA,"^")
+53 QUIT
+54 ;
HDR ;
+1 SET AGCN=0
+2 FOR
SET AGCN=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN))
IF 'AGCN
QUIT
Begin DoDot:1
+3 IF $PIECE(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'=""
QUIT
+4 SET HDR=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,0)),U,2)
+5 SET HEADR=HEADR_HDR_"^"
End DoDot:1
+6 SET HEADR=$$TKO^AGGUL1(HEADR,"^")
+7 QUIT
+8 ;
RACE(DATA,DFN) ; EP -- AGG PATIENT RACE
+1 ; Input
+2 ; DFN - Patients DFN or internal entry number
+3 ;
+4 NEW UID,II,HDR,BN,RACE,METH
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("AGGPTRCE",UID))
+7 KILL @DATA
+8 ;
+9 SET II=0
+10 ;
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER"
+12 ;
+13 SET HDR="I00010AGGRDA^T00030AGRACE^T00030AGRMET"_$CHAR(30)
+14 SET @DATA@(II)=HDR
+15 SET BN=0
+16 FOR
SET BN=$ORDER(^DPT(DFN,.02,BN))
IF 'BN
QUIT
Begin DoDot:1
+17 NEW DA,IENS
+18 SET DA(1)=DFN
SET DA=BN
SET IENS=$$IENS^DILF(.DA)
+19 SET RACE=$$GET1^DIQ(2.02,IENS,.01,"I")_$CHAR(28)_$$GET1^DIQ(2.02,IENS,.01,"E")
+20 SET METH=$$GET1^DIQ(2.02,IENS,.02,"I")_$CHAR(28)_$$GET1^DIQ(2.02,IENS,.02,"E")
+21 SET II=II+1
SET @DATA@(II)=BN_U_RACE_U_METH_$CHAR(30)
End DoDot:1
+22 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
ETHN(DFN,FLD) ; EP - Patient's Ethnicity
+1 NEW BN,VAL
+2 SET BN=0
SET VAL=""
+3 FOR
SET BN=$ORDER(^DPT(DFN,.06,BN))
IF 'BN
QUIT
Begin DoDot:1
+4 NEW DA,IENS
+5 SET DA(1)=DFN
SET DA=BN
SET IENS=$$IENS^DILF(.DA)
+6 SET VAL=$$GET1^DIQ(2.06,IENS,FLD,"I")_$CHAR(28)_$$GET1^DIQ(2.06,IENS,FLD,"E")
End DoDot:1
+7 QUIT VAL
+8 ;
RCE(DFN,FLD) ; EP - Patient's Race
+1 NEW BN,VAL
+2 SET BN=0
SET VAL=""
+3 FOR
SET BN=$ORDER(^DPT(DFN,.02,BN))
IF 'BN
QUIT
Begin DoDot:1
+4 NEW DA,IENS
+5 SET DA(1)=DFN
SET DA=BN
SET IENS=$$IENS^DILF(.DA)
+6 SET VAL=$$GET1^DIQ(2.02,IENS,FLD,"I")_$CHAR(28)_$$GET1^DIQ(2.02,IENS,FLD,"E")
End DoDot:1
+7 QUIT VAL
+8 ;
SEQ(DEF,DFN) ;EP - Sequence number
+1 NEW AGINSN1,AGINS,AGCAT,SEQ,QFL,AGN,INSNM,INSPTR
+2 DO EP^AGINS
+3 DO LOADCAT^AGCAT
+4 SET INSNM=$$UP^XLFSTR(DEF)
+5 SET INSPTR=$$FIND1^DIC(9999999.18,"","BX",INSNM,"","","ERROR")
+6 IF $GET(RIEN)=""
SET RIEN=DFN
+7 SET SEQ=""
SET QFL=0
+8 FOR
SET SEQ=$ORDER(AGINSNN(SEQ))
IF SEQ=""
QUIT
Begin DoDot:1
+9 IF $PIECE($GET(AGINSNN(SEQ)),U,2)=INSPTR
IF $PIECE($GET(AGINSNN(SEQ)),U,11)[RIEN
SET QFL=1
QUIT
+10 SET AGN=""
+11 FOR
SET AGN=$ORDER(AGINSNN(SEQ,AGN))
IF AGN=""
QUIT
Begin DoDot:2
+12 IF $PIECE(AGINSNN(SEQ,AGN),U,2)=INSPTR
IF $PIECE(AGINSNN(SEQ,AGN),U,11)[RIEN
SET QFL=1
End DoDot:2
IF QFL
QUIT
+13 IF DEF="Private Insurance"
SET INSPTR=$$GET1^DIQ(9000006.11,IENS,.01,"I")
+14 IF $PIECE($GET(AGINSNN(SEQ)),U,2)=INSPTR
IF $PIECE($GET(AGINSNN(SEQ)),U,11)[RIEN
SET QFL=1
QUIT
+15 SET AGN=""
+16 FOR
SET AGN=$ORDER(AGINSNN(SEQ,AGN))
IF AGN=""
QUIT
Begin DoDot:2
+17 IF $PIECE(AGINSNN(SEQ,AGN),U,2)=INSPTR
IF $PIECE(AGINSNN(SEQ,AGN),U,11)[RIEN
SET QFL=1
End DoDot:2
IF QFL
QUIT
End DoDot:1
IF QFL
QUIT
+18 KILL AGINSN1,AGINS,AGCAT,AGINSNN
+19 QUIT SEQ
+20 ;
+21 NEW SEQ,SFLD
+22 SET SEQ=""
+23 SET SFLD=$SELECT(FILE=9000006.11:.01,1:.02)
+24 SET INSPTR=$$GET1^DIQ(FILE,IENS,SFLD,"I")
+25 IF $GET(DFN)=""
SET DFN=RIEN
+26 IF '$DATA(^AUPNICP("C",DFN))
QUIT SEQ
+27 SET SIEN=""
SET QFL=0
+28 FOR
SET SIEN=$ORDER(^AUPNICP("C",DFN,SIEN))
IF SIEN=""!(QFL)
QUIT
Begin DoDot:1
+29 IF $PIECE(^AUPNICP(SIEN,0),U,14)'[IENS
QUIT
+30 IF $PIECE(^AUPNICP(SIEN,0),U,3)=INSPTR
SET SEQ=$PIECE(^AUPNICP(SIEN,0),U,5)
End DoDot:1
+31 QUIT SEQ
