BQIGPRA4 ;PRXM/HC/ALA - Calculate GPRA for single patient ; 26 Jul 2006 10:05 AM
;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
;
Q
;
SNG(DATA,DFN) ;EP -- BQI GPRA POPULATE BY PATIENT
;Description
; Get GPRA for a single patient
;Input
; DFN - Patient internal entry number
NEW UID,II,BQIGREF,BQIDATA,BQIROU,BGPIND,BGPBD,BGPED,BGPBBD,BGPBED,X
NEW BGPPBD,BGPPED,BGPPER,BGPQTR,BGPRTYPE,BGPRPT,BGP3YE,BGPP3YE,BGPB3YE
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIGPSNG",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIGPRA4 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S BQIGREF=$NA(^TMP("BQIGPRA",UID))
S BQIDATA=$NA(^BQIPAT)
K @BQIGREF,@BQIDATA@(DFN,30)
;
S @DATA@(II)="I00010RESULT"_$C(30)
;
; If patient is deceased, don't calculate
I $P($G(^DPT(DFN,.35)),U,1)'="" G DONE
; If patient has no active HRNs, quit
I '$$HRN^BQIUL1(DFN) G DONE
; If patient has no visit in last 3 years, quit
I '$$VTHR^BQIUL1(DFN) G DONE
;
D INP^BQINIGHT
I $G(BQIROU)="" Q
;
I $T(@("BQI^"_BQIROU))="" Q
;
NEW VER,BQX,XN
S VER=$$VERSION^XPDUTL("BGP")
;
I VER>7.0 D
. S BQX=""
. F S BQX=$O(^BQI(90506.1,"AC","G",BQX)) Q:BQX="" D
.. I $P(^BQI(90506.1,BQX,0),U,10)=1 Q
.. S X=$P(^BQI(90506.1,BQX,0),U,1),XN=$P(X,"_",2)
.. S X=$P(@BQIMEASG@(XN,0),U,1),BGPIND(X)=""
;
; Define the time frame for the patient
S BGPBD=$$DATE^BQIUL1("T-12M"),BGPED=DT
S BGPBBD="300"_$E(BGPBD,4,7),BGPBED="300"_$E(BGPED,4,7)
S BGPPBD=$$DATE^BQIUL1("T-24M"),BGPPED=$$DATE^BQIUL1("T-12M")
S BGPPER=$E($$DT^XLFDT(),1,3)_"0000"
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)
S BGPRTYPE=4,BGPRPT=4
S BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
S BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
S BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
;
S BQIPUP(90507.5,DFN_",",.02)=BQIYR
S BQIPUP(90507.5,DFN_",",.03)=BGPBD
S BQIPUP(90507.5,DFN_",",.04)=BGPED
S BQIPUP(90507.5,DFN_",",.05)=$$NOW^XLFDT()
D FILE^DIE("","BQIPUP","ERROR")
K BQIPUP
;
; Setup taxonomies
I VER>14.1 D
. I $T(UNFOLDTX^BGP8UTL2)="" Q
. D UNFOLDTX^BGP8UTL2
D @("BQI^"_BQIROU_"(DFN,.BQIGREF)")
;
K ^XTMP("BGP15TAX",$J),^XTMP("BGPSNOMEDSUBSET",$J)
;
; if the patient doesn't already exist in the iCare Patient file, add them
I $G(^BQIPAT(DFN,0))="" D
. NEW DIC,X,DINUM,DLAYGO
. S (X,DINUM)=DFN,DLAYGO=90507.5,DIC="^BQIPAT(",DIC(0)="L"
. K DO,DD D FILE^DICN
;
S @BQIDATA@(DFN,30,0)="^90507.53^^"
;
; if the patient doesn't meet any GPRA logic, quit
I '$D(@BQIGREF@(DFN)) Q
;
NEW SIND,IND,MEAS,MCT,CT,GPMEAS
S SIND="",CT=0
F S SIND=$O(^BQI(90506.1,"AC","G",SIND)) Q:SIND="" D
. S CT=CT+1
. I $P(^BQI(90506.1,SIND,0),U,10)=1 Q
. S @BQIDATA@(DFN,30,CT,0)=$P(^BQI(90506.1,SIND,0),U,1)
. S @BQIDATA@(DFN,30,"B",$P(^BQI(90506.1,SIND,0),U,1),CT)=""
;
S IND=0
F S IND=$O(@BQIGREF@(DFN,IND)) Q:IND="" D
. S MEAS=0
. F S MEAS=$O(@BQIGREF@(DFN,IND,MEAS)) Q:MEAS="" D
.. ;Q:'$$SUM^BQIGPUTL(BQIYR,MEAS)
.. S GPMEAS=BQIYR_"_"_MEAS
.. S MCT=$O(^BQIPAT(DFN,30,"B",GPMEAS,"")) I MCT="" Q
.. S $P(@BQIDATA@(DFN,30,MCT,0),U,2)=$P(@BQIGREF@(DFN,IND),U,2)
.. S $P(@BQIDATA@(DFN,30,MCT,0),U,3)=$P(@BQIGREF@(DFN,IND,MEAS),U,2)
.. S $P(@BQIDATA@(DFN,30,MCT,0),U,4)=$P(@BQIGREF@(DFN,IND,MEAS),U,3)
;
; Create cross-references
K @BQIGREF
;NEW DA,DIK
;S DA=DFN,DIK="^BQIPAT(" D IX1^DIK
;
DONE ;
K BGPNUM,BGPDEN
S II=II+1,@DATA@(II)="1"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)="-1"_$C(30)
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
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
+2 ;
+3 QUIT
+4 ;
SNG(DATA,DFN) ;EP -- BQI GPRA POPULATE BY PATIENT
+1 ;Description
+2 ; Get GPRA for a single patient
+3 ;Input
+4 ; DFN - Patient internal entry number
+5 NEW UID,II,BQIGREF,BQIDATA,BQIROU,BGPIND,BGPBD,BGPED,BGPBBD,BGPBED,X
+6 NEW BGPPBD,BGPPED,BGPPER,BGPQTR,BGPRTYPE,BGPRPT,BGP3YE,BGPP3YE,BGPB3YE
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("BQIGPSNG",UID))
+9 KILL @DATA
+10 ;
+11 SET II=0
+12 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIGPRA4 D UNWIND^%ZTER"
+13 ;
+14 SET BQIGREF=$NAME(^TMP("BQIGPRA",UID))
+15 SET BQIDATA=$NAME(^BQIPAT)
+16 KILL @BQIGREF,@BQIDATA@(DFN,30)
+17 ;
+18 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+19 ;
+20 ; If patient is deceased, don't calculate
+21 IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""
GOTO DONE
+22 ; If patient has no active HRNs, quit
+23 IF '$$HRN^BQIUL1(DFN)
GOTO DONE
+24 ; If patient has no visit in last 3 years, quit
+25 IF '$$VTHR^BQIUL1(DFN)
GOTO DONE
+26 ;
+27 DO INP^BQINIGHT
+28 IF $GET(BQIROU)=""
QUIT
+29 ;
+30 IF $TEXT(@("BQI^"_BQIROU))=""
QUIT
+31 ;
+32 NEW VER,BQX,XN
+33 SET VER=$$VERSION^XPDUTL("BGP")
+34 ;
+35 IF VER>7.0
Begin DoDot:1
+36 SET BQX=""
+37 FOR
SET BQX=$ORDER(^BQI(90506.1,"AC","G",BQX))
IF BQX=""
QUIT
Begin DoDot:2
+38 IF $PIECE(^BQI(90506.1,BQX,0),U,10)=1
QUIT
+39 SET X=$PIECE(^BQI(90506.1,BQX,0),U,1)
SET XN=$PIECE(X,"_",2)
+40 SET X=$PIECE(@BQIMEASG@(XN,0),U,1)
SET BGPIND(X)=""
End DoDot:2
End DoDot:1
+41 ;
+42 ; Define the time frame for the patient
+43 SET BGPBD=$$DATE^BQIUL1("T-12M")
SET BGPED=DT
+44 SET BGPBBD="300"_$EXTRACT(BGPBD,4,7)
SET BGPBED="300"_$EXTRACT(BGPED,4,7)
+45 SET BGPPBD=$$DATE^BQIUL1("T-24M")
SET BGPPED=$$DATE^BQIUL1("T-12M")
+46 SET BGPPER=$EXTRACT($$DT^XLFDT(),1,3)_"0000"
+47 SET BGPQTR=$SELECT(BGPBD>($EXTRACT(BGPBD,1,3)_"0101")&(BGPBD<($EXTRACT(BGPBD,1,3)_"0331")):1,BGPBD>($EXTRACT(BGPBD,1,3)_"0401")&(BGPBD<($EXTRACT(BGPBD,1,3)_"0630")):2,BGPBD>($EXTRACT(BGPBD,1,3)_"0701")&(BGPBD<($EXTRACT(BGPBD,1,3)_"0930")):3,1:4
)
+48 SET BGPRTYPE=4
SET BGPRPT=4
+49 SET BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
+50 SET BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
+51 SET BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
+52 ;
+53 SET BQIPUP(90507.5,DFN_",",.02)=BQIYR
+54 SET BQIPUP(90507.5,DFN_",",.03)=BGPBD
+55 SET BQIPUP(90507.5,DFN_",",.04)=BGPED
+56 SET BQIPUP(90507.5,DFN_",",.05)=$$NOW^XLFDT()
+57 DO FILE^DIE("","BQIPUP","ERROR")
+58 KILL BQIPUP
+59 ;
+60 ; Setup taxonomies
+61 IF VER>14.1
Begin DoDot:1
+62 IF $TEXT(UNFOLDTX^BGP8UTL2)=""
QUIT
+63 DO UNFOLDTX^BGP8UTL2
End DoDot:1
+64 DO @("BQI^"_BQIROU_"(DFN,.BQIGREF)")
+65 ;
+66 KILL ^XTMP("BGP15TAX",$JOB),^XTMP("BGPSNOMEDSUBSET",$JOB)
+67 ;
+68 ; if the patient doesn't already exist in the iCare Patient file, add them
+69 IF $GET(^BQIPAT(DFN,0))=""
Begin DoDot:1
+70 NEW DIC,X,DINUM,DLAYGO
+71 SET (X,DINUM)=DFN
SET DLAYGO=90507.5
SET DIC="^BQIPAT("
SET DIC(0)="L"
+72 KILL DO,DD
DO FILE^DICN
End DoDot:1
+73 ;
+74 SET @BQIDATA@(DFN,30,0)="^90507.53^^"
+75 ;
+76 ; if the patient doesn't meet any GPRA logic, quit
+77 IF '$DATA(@BQIGREF@(DFN))
QUIT
+78 ;
+79 NEW SIND,IND,MEAS,MCT,CT,GPMEAS
+80 SET SIND=""
SET CT=0
+81 FOR
SET SIND=$ORDER(^BQI(90506.1,"AC","G",SIND))
IF SIND=""
QUIT
Begin DoDot:1
+82 SET CT=CT+1
+83 IF $PIECE(^BQI(90506.1,SIND,0),U,10)=1
QUIT
+84 SET @BQIDATA@(DFN,30,CT,0)=$PIECE(^BQI(90506.1,SIND,0),U,1)
+85 SET @BQIDATA@(DFN,30,"B",$PIECE(^BQI(90506.1,SIND,0),U,1),CT)=""
End DoDot:1
+86 ;
+87 SET IND=0
+88 FOR
SET IND=$ORDER(@BQIGREF@(DFN,IND))
IF IND=""
QUIT
Begin DoDot:1
+89 SET MEAS=0
+90 FOR
SET MEAS=$ORDER(@BQIGREF@(DFN,IND,MEAS))
IF MEAS=""
QUIT
Begin DoDot:2
+91 ;Q:'$$SUM^BQIGPUTL(BQIYR,MEAS)
+92 SET GPMEAS=BQIYR_"_"_MEAS
+93 SET MCT=$ORDER(^BQIPAT(DFN,30,"B",GPMEAS,""))
IF MCT=""
QUIT
+94 SET $PIECE(@BQIDATA@(DFN,30,MCT,0),U,2)=$PIECE(@BQIGREF@(DFN,IND),U,2)
+95 SET $PIECE(@BQIDATA@(DFN,30,MCT,0),U,3)=$PIECE(@BQIGREF@(DFN,IND,MEAS),U,2)
+96 SET $PIECE(@BQIDATA@(DFN,30,MCT,0),U,4)=$PIECE(@BQIGREF@(DFN,IND,MEAS),U,3)
End DoDot:2
End DoDot:1
+97 ;
+98 ; Create cross-references
+99 KILL @BQIGREF
+100 ;NEW DA,DIK
+101 ;S DA=DFN,DIK="^BQIPAT(" D IX1^DIK
+102 ;
DONE ;
+1 KILL BGPNUM,BGPDEN
+2 SET II=II+1
SET @DATA@(II)="1"_$CHAR(30)
+3 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+4 QUIT
+5 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
+6 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+7 QUIT
