BQIPTDMG ;VNGT/HS/ALA-iCare Demographics RPCs ; 14 Jan 2009 12:47 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
;
GET(DATA,DFN) ; EP -- BQI PATIENT EDIT DATA
; Input
; DFN - Patients DFN or internal entry number
;
NEW UID,II,HEADR,BN,RACE,METH
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTDMG",UID))
K @DATA
;
S II=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTDDG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S VFIEN=$O(^BQI(90506.3,"B","Patient Edit",""))
I VFIEN="" S BMXSEC="RPC Call Failed: Patient Edit Definition does not exist." Q
S FILE=$P(^BQI(90506.3,VFIEN,0),U,2)
;
S ORD="",HEADR="",VALUE=""
F S ORD=$O(^BQI(90506.3,VFIEN,10,"C",ORD)) Q:ORD="" D
. S IEN=""
. F S IEN=$O(^BQI(90506.3,VFIEN,10,"C",ORD,IEN)) Q:IEN="" D
.. I $P(^BQI(90506.3,VFIEN,10,IEN,0),U,11)=1 Q
.. S TYPE=$P($G(^BQI(90506.3,VFIEN,10,IEN,1)),U,1)
.. S HEADR=HEADR_$P(^BQI(90506.3,VFIEN,10,IEN,0),U,2)_U
.. I TYPE="M" S VAL="",VALUE=VALUE_VAL_U Q
.. S FLD=$P($G(^BQI(90506.3,VFIEN,10,IEN,3)),U,1)
.. S CODE=$P(^BQI(90506.3,VFIEN,10,IEN,0),U,7)
.. S EXEC=$G(^BQI(90506.3,VFIEN,10,IEN,8))
.. S VAL=""
.. I FLD="" D
... S STVW=$O(^BQI(90506.1,"B",CODE,""))
... I STVW="",EXEC'="" X EXEC Q
... I STVW="",EXEC="" Q
... D GVAL^BQIPLVWP
.. I FLD'="" D
... I TYPE'="T",TYPE'="C" S VAL=$$GET1^DIQ(FILE,DFN_",",FLD,"E") Q
... S VAL=$$GET1^DIQ(FILE,DFN_",",FLD,"I")_$C(28)_$$GET1^DIQ(FILE,DFN_",",FLD,"E")
.. S VALUE=VALUE_VAL_U
S HEADR=$$TKO^BQIUL1(HEADR,"^"),VALUE=$$TKO^BQIUL1(VALUE,"^")
S @DATA@(II)=HEADR_$C(30)
S II=II+1,@DATA@(II)=VALUE_$C(30)
;
G DONE
;
RACE(DATA,DFN) ; EP -- BQI 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("BQIPTDMG",UID))
K @DATA
;
S II=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTDDG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HDR="I00010BQIRDA^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
;
ET(DFN) ; EP - List of patient's ethinicities
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=VAL_$$GET1^DIQ(2.06,IENS,.01,"E")_$C(10)_$C(13)
Q $$TKO^BQIUL1(VAL,$C(10)_$C(13))
;
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
;
RC(DFN) ; EP - List of patient's race(s)
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=VAL_$$GET1^DIQ(2.02,IENS,.01,"E")_$C(10)_$C(13)
Q $$TKO^BQIUL1(VAL,$C(10)_$C(13))
BQIPTDMG ;VNGT/HS/ALA-iCare Demographics RPCs ; 14 Jan 2009 12:47 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 ;
GET(DATA,DFN) ; EP -- BQI PATIENT EDIT DATA
+1 ; Input
+2 ; DFN - Patients DFN or internal entry number
+3 ;
+4 NEW UID,II,HEADR,BN,RACE,METH
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BQIPTDMG",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^BQIPTDDG D UNWIND^%ZTER"
+12 ;
+13 SET VFIEN=$ORDER(^BQI(90506.3,"B","Patient Edit",""))
+14 IF VFIEN=""
SET BMXSEC="RPC Call Failed: Patient Edit Definition does not exist."
QUIT
+15 SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
+16 ;
+17 SET ORD=""
SET HEADR=""
SET VALUE=""
+18 FOR
SET ORD=$ORDER(^BQI(90506.3,VFIEN,10,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+19 SET IEN=""
+20 FOR
SET IEN=$ORDER(^BQI(90506.3,VFIEN,10,"C",ORD,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+21 IF $PIECE(^BQI(90506.3,VFIEN,10,IEN,0),U,11)=1
QUIT
+22 SET TYPE=$PIECE($GET(^BQI(90506.3,VFIEN,10,IEN,1)),U,1)
+23 SET HEADR=HEADR_$PIECE(^BQI(90506.3,VFIEN,10,IEN,0),U,2)_U
+24 IF TYPE="M"
SET VAL=""
SET VALUE=VALUE_VAL_U
QUIT
+25 SET FLD=$PIECE($GET(^BQI(90506.3,VFIEN,10,IEN,3)),U,1)
+26 SET CODE=$PIECE(^BQI(90506.3,VFIEN,10,IEN,0),U,7)
+27 SET EXEC=$GET(^BQI(90506.3,VFIEN,10,IEN,8))
+28 SET VAL=""
+29 IF FLD=""
Begin DoDot:3
+30 SET STVW=$ORDER(^BQI(90506.1,"B",CODE,""))
+31 IF STVW=""
IF EXEC'=""
XECUTE EXEC
QUIT
+32 IF STVW=""
IF EXEC=""
QUIT
+33 DO GVAL^BQIPLVWP
End DoDot:3
+34 IF FLD'=""
Begin DoDot:3
+35 IF TYPE'="T"
IF TYPE'="C"
SET VAL=$$GET1^DIQ(FILE,DFN_",",FLD,"E")
QUIT
+36 SET VAL=$$GET1^DIQ(FILE,DFN_",",FLD,"I")_$CHAR(28)_$$GET1^DIQ(FILE,DFN_",",FLD,"E")
End DoDot:3
+37 SET VALUE=VALUE_VAL_U
End DoDot:2
End DoDot:1
+38 SET HEADR=$$TKO^BQIUL1(HEADR,"^")
SET VALUE=$$TKO^BQIUL1(VALUE,"^")
+39 SET @DATA@(II)=HEADR_$CHAR(30)
+40 SET II=II+1
SET @DATA@(II)=VALUE_$CHAR(30)
+41 ;
+42 GOTO DONE
+43 ;
RACE(DATA,DFN) ; EP -- BQI 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("BQIPTDMG",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^BQIPTDDG D UNWIND^%ZTER"
+12 ;
+13 SET HDR="I00010BQIRDA^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 ;
ET(DFN) ; EP - List of patient's ethinicities
+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=VAL_$$GET1^DIQ(2.06,IENS,.01,"E")_$CHAR(10)_$CHAR(13)
End DoDot:1
+7 QUIT $$TKO^BQIUL1(VAL,$CHAR(10)_$CHAR(13))
+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 ;
RC(DFN) ; EP - List of patient's race(s)
+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=VAL_$$GET1^DIQ(2.02,IENS,.01,"E")_$CHAR(10)_$CHAR(13)
End DoDot:1
+7 QUIT $$TKO^BQIUL1(VAL,$CHAR(10)_$CHAR(13))
