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

BQIGPRA4.m

Go to the documentation of this file. 
  1. BQIGPRA4 ;PRXM/HC/ALA - Calculate GPRA for single patient ; 26 Jul 2006  10:05 AM
  1.  ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
  1.  ;
  1.  Q
  1.  ;
  1. SNG(DATA,DFN) ;EP -- BQI GPRA POPULATE BY PATIENT
  1.  ;Description
  1.  ;  Get GPRA for a single patient
  1.  ;Input
  1.  ;  DFN - Patient internal entry number
  1.  NEW UID,II,BQIGREF,BQIDATA,BQIROU,BGPIND,BGPBD,BGPED,BGPBBD,BGPBED,X
  1.  NEW BGPPBD,BGPPED,BGPPER,BGPQTR,BGPRTYPE,BGPRPT,BGP3YE,BGPP3YE,BGPB3YE
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIGPSNG",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIGPRA4 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S BQIGREF=$NA(^TMP("BQIGPRA",UID))
  1.  S BQIDATA=$NA(^BQIPAT)
  1.  K @BQIGREF,@BQIDATA@(DFN,30)
  1.  ;
  1.  S @DATA@(II)="I00010RESULT"_$C(30)
  1.  ;
  1.  ; If patient is deceased, don't calculate
  1.  I $P($G(^DPT(DFN,.35)),U,1)'="" G DONE
  1.  ; If patient has no active HRNs, quit
  1.  I '$$HRN^BQIUL1(DFN) G DONE
  1.  ; If patient has no visit in last 3 years, quit
  1.  I '$$VTHR^BQIUL1(DFN) G DONE
  1.  ;
  1.  D INP^BQINIGHT
  1.  I $G(BQIROU)="" Q
  1.  ;
  1.  I $T(@("BQI^"_BQIROU))="" Q
  1.  ;
  1.  NEW VER,BQX,XN
  1.  S VER=$$VERSION^XPDUTL("BGP")
  1.  ;
  1.  I VER>7.0 D
  1.  . S BQX=""
  1.  . F  S BQX=$O(^BQI(90506.1,"AC","G",BQX)) Q:BQX=""  D
  1.  .. I $P(^BQI(90506.1,BQX,0),U,10)=1 Q
  1.  .. S X=$P(^BQI(90506.1,BQX,0),U,1),XN=$P(X,"_",2)
  1.  .. S X=$P(@BQIMEASG@(XN,0),U,1),BGPIND(X)=""
  1.  ;
  1.  ; Define the time frame for the patient
  1.  S BGPBD=$$DATE^BQIUL1("T-12M"),BGPED=DT
  1.  S BGPBBD="300"_$E(BGPBD,4,7),BGPBED="300"_$E(BGPED,4,7)
  1.  S BGPPBD=$$DATE^BQIUL1("T-24M"),BGPPED=$$DATE^BQIUL1("T-12M")
  1.  S BGPPER=$E($$DT^XLFDT(),1,3)_"0000"
  1.  S BGPQTR=$S(BGPBD>($E(BGPBD,1,3)_"0101")&(BGPBD<($E(BGPBD,1,3)_"0331")):1,BGPBD>($E(BGPBD,1,3)_"0401")&(BGPBD<($E(BGPBD,1,3)_"0630")):2,BGPBD>($E(BGPBD,1,3)_"0701")&(BGPBD<($E(BGPBD,1,3)_"0930")):3,1:4)
  1.  S BGPRTYPE=4,BGPRPT=4
  1.  S BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
  1.  S BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
  1.  S BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
  1.  ;
  1.  S BQIPUP(90507.5,DFN_",",.02)=BQIYR
  1.  S BQIPUP(90507.5,DFN_",",.03)=BGPBD
  1.  S BQIPUP(90507.5,DFN_",",.04)=BGPED
  1.  S BQIPUP(90507.5,DFN_",",.05)=$$NOW^XLFDT()
  1.  D FILE^DIE("","BQIPUP","ERROR")
  1.  K BQIPUP
  1.  ;
  1.  ; Setup taxonomies
  1.  I VER>14.1 D
  1.  . I $T(UNFOLDTX^BGP8UTL2)="" Q
  1.  . D UNFOLDTX^BGP8UTL2
  1.  D @("BQI^"_BQIROU_"(DFN,.BQIGREF)")
  1.  ;
  1.  K ^XTMP("BGP15TAX",$J),^XTMP("BGPSNOMEDSUBSET",$J)
  1.  ;
  1.  ;  if the patient doesn't already exist in the iCare Patient file, add them
  1.  I $G(^BQIPAT(DFN,0))="" D
  1.  . NEW DIC,X,DINUM,DLAYGO
  1.  . S (X,DINUM)=DFN,DLAYGO=90507.5,DIC="^BQIPAT(",DIC(0)="L"
  1.  . K DO,DD D FILE^DICN
  1.  ;
  1.  S @BQIDATA@(DFN,30,0)="^90507.53^^"
  1.  ;
  1.  ; if the patient doesn't meet any GPRA logic, quit
  1.  I '$D(@BQIGREF@(DFN)) Q
  1.  ;
  1.  NEW SIND,IND,MEAS,MCT,CT,GPMEAS
  1.  S SIND="",CT=0
  1.  F  S SIND=$O(^BQI(90506.1,"AC","G",SIND)) Q:SIND=""  D
  1.  . S CT=CT+1
  1.  . I $P(^BQI(90506.1,SIND,0),U,10)=1 Q
  1.  . S @BQIDATA@(DFN,30,CT,0)=$P(^BQI(90506.1,SIND,0),U,1)
  1.  . S @BQIDATA@(DFN,30,"B",$P(^BQI(90506.1,SIND,0),U,1),CT)=""
  1.  ;
  1.  S IND=0
  1.  F  S IND=$O(@BQIGREF@(DFN,IND)) Q:IND=""  D
  1.  . S MEAS=0
  1.  . F  S MEAS=$O(@BQIGREF@(DFN,IND,MEAS)) Q:MEAS=""  D
  1.  .. ;Q:'$$SUM^BQIGPUTL(BQIYR,MEAS)
  1.  .. S GPMEAS=BQIYR_"_"_MEAS
  1.  .. S MCT=$O(^BQIPAT(DFN,30,"B",GPMEAS,"")) I MCT="" Q
  1.  .. S $P(@BQIDATA@(DFN,30,MCT,0),U,2)=$P(@BQIGREF@(DFN,IND),U,2)
  1.  .. S $P(@BQIDATA@(DFN,30,MCT,0),U,3)=$P(@BQIGREF@(DFN,IND,MEAS),U,2)
  1.  .. S $P(@BQIDATA@(DFN,30,MCT,0),U,4)=$P(@BQIGREF@(DFN,IND,MEAS),U,3)
  1.  ;
  1.  ;  Create cross-references
  1.  K @BQIGREF
  1.  ;NEW DA,DIK
  1.  ;S DA=DFN,DIK="^BQIPAT(" D IX1^DIK
  1.  ;
  1. DONE ;
  1.  K BGPNUM,BGPDEN
  1.  S II=II+1,@DATA@(II)="1"_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)="-1"_$C(30)
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q