Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIPTDMG

BQIPTDMG.m

Go to the documentation of this file. 
  1. BQIPTDMG ;VNGT/HS/ALA-iCare Demographics RPCs ; 14 Jan 2009  12:47 PM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1.  ;
  1. GET(DATA,DFN) ; EP -- BQI PATIENT EDIT DATA
  1.  ; Input
  1.  ;    DFN    - Patients DFN or internal entry number
  1.  ;
  1.  NEW UID,II,HEADR,BN,RACE,METH
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTDMG",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTDDG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S VFIEN=$O(^BQI(90506.3,"B","Patient Edit",""))
  1.  I VFIEN="" S BMXSEC="RPC Call Failed: Patient Edit Definition does not exist." Q
  1.  S FILE=$P(^BQI(90506.3,VFIEN,0),U,2)
  1.  ;
  1.  S ORD="",HEADR="",VALUE=""
  1.  F  S ORD=$O(^BQI(90506.3,VFIEN,10,"C",ORD)) Q:ORD=""  D
  1.  . S IEN=""
  1.  . F  S IEN=$O(^BQI(90506.3,VFIEN,10,"C",ORD,IEN)) Q:IEN=""  D
  1.  .. I $P(^BQI(90506.3,VFIEN,10,IEN,0),U,11)=1 Q
  1.  .. S TYPE=$P($G(^BQI(90506.3,VFIEN,10,IEN,1)),U,1)
  1.  .. S HEADR=HEADR_$P(^BQI(90506.3,VFIEN,10,IEN,0),U,2)_U
  1.  .. I TYPE="M" S VAL="",VALUE=VALUE_VAL_U Q
  1.  .. S FLD=$P($G(^BQI(90506.3,VFIEN,10,IEN,3)),U,1)
  1.  .. S CODE=$P(^BQI(90506.3,VFIEN,10,IEN,0),U,7)
  1.  .. S EXEC=$G(^BQI(90506.3,VFIEN,10,IEN,8))
  1.  .. S VAL=""
  1.  .. I FLD="" D
  1.  ... S STVW=$O(^BQI(90506.1,"B",CODE,""))
  1.  ... I STVW="",EXEC'="" X EXEC Q
  1.  ... I STVW="",EXEC="" Q
  1.  ... D GVAL^BQIPLVWP
  1.  .. I FLD'="" D
  1.  ... I TYPE'="T",TYPE'="C" S VAL=$$GET1^DIQ(FILE,DFN_",",FLD,"E") Q
  1.  ... S VAL=$$GET1^DIQ(FILE,DFN_",",FLD,"I")_$C(28)_$$GET1^DIQ(FILE,DFN_",",FLD,"E")
  1.  .. S VALUE=VALUE_VAL_U
  1.  S HEADR=$$TKO^BQIUL1(HEADR,"^"),VALUE=$$TKO^BQIUL1(VALUE,"^")
  1.  S @DATA@(II)=HEADR_$C(30)
  1.  S II=II+1,@DATA@(II)=VALUE_$C(30)
  1.  ;
  1.  G DONE
  1.  ;
  1. RACE(DATA,DFN) ; EP -- BQI PATIENT RACE
  1.  ; Input
  1.  ;    DFN    - Patients DFN or internal entry number
  1.  ;
  1.  NEW UID,II,HDR,BN,RACE,METH
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTDMG",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTDDG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S HDR="I00010BQIRDA^T00030AGRACE^T00030AGRMET"_$C(30)
  1.  S @DATA@(II)=HDR
  1.  S BN=0
  1.  F  S BN=$O(^DPT(DFN,.02,BN)) Q:'BN  D
  1.  . NEW DA,IENS
  1.  . S DA(1)=DFN,DA=BN,IENS=$$IENS^DILF(.DA)
  1.  . S RACE=$$GET1^DIQ(2.02,IENS,.01,"I")_$C(28)_$$GET1^DIQ(2.02,IENS,.01,"E")
  1.  . S METH=$$GET1^DIQ(2.02,IENS,.02,"I")_$C(28)_$$GET1^DIQ(2.02,IENS,.02,"E")
  1.  . S II=II+1,@DATA@(II)=BN_U_RACE_U_METH_$C(30)
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ETHN(DFN,FLD) ; EP - Patient's Ethnicity
  1.  NEW BN,VAL
  1.  S BN=0,VAL=""
  1.  F  S BN=$O(^DPT(DFN,.06,BN)) Q:'BN  D
  1.  . NEW DA,IENS
  1.  . S DA(1)=DFN,DA=BN,IENS=$$IENS^DILF(.DA)
  1.  . S VAL=$$GET1^DIQ(2.06,IENS,FLD,"I")_$C(28)_$$GET1^DIQ(2.06,IENS,FLD,"E")
  1.  Q VAL
  1.  ;
  1. ET(DFN) ; EP - List of patient's ethinicities
  1.  NEW BN,VAL
  1.  S BN=0,VAL=""
  1.  F  S BN=$O(^DPT(DFN,.06,BN)) Q:'BN  D
  1.  . NEW DA,IENS
  1.  . S DA(1)=DFN,DA=BN,IENS=$$IENS^DILF(.DA)
  1.  . S VAL=VAL_$$GET1^DIQ(2.06,IENS,.01,"E")_$C(10)_$C(13)
  1.  Q $$TKO^BQIUL1(VAL,$C(10)_$C(13))
  1.  ;
  1. RCE(DFN,FLD) ; EP - Patient's Race
  1.  NEW BN,VAL
  1.  S BN=0,VAL=""
  1.  F  S BN=$O(^DPT(DFN,.02,BN)) Q:'BN  D
  1.  . NEW DA,IENS
  1.  . S DA(1)=DFN,DA=BN,IENS=$$IENS^DILF(.DA)
  1.  . S VAL=$$GET1^DIQ(2.02,IENS,FLD,"I")_$C(28)_$$GET1^DIQ(2.02,IENS,FLD,"E")
  1.  Q VAL
  1.  ;
  1. RC(DFN) ; EP - List of patient's race(s)
  1.  NEW BN,VAL
  1.  S BN=0,VAL=""
  1.  F  S BN=$O(^DPT(DFN,.02,BN)) Q:'BN  D
  1.  . NEW DA,IENS
  1.  . S DA(1)=DFN,DA=BN,IENS=$$IENS^DILF(.DA)
  1.  . S VAL=VAL_$$GET1^DIQ(2.02,IENS,.01,"E")_$C(10)_$C(13)
  1.  Q $$TKO^BQIUL1(VAL,$C(10)_$C(13))