BQITRPRT ;PRXM/HC/ALA-Get Treatment Prompts for a Patient ; 18 May 2007 12:05 PM
;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
;
EN(DATA,DFN,NUM) ;EP -- BQI PATIENT TRMT PROMPTS
; Input
; DFN - Patient internal entry number
;
NEW DXCAT,DOD,DXFND,UID,II,CT,TRIEN,TIT,RMK,REMARK,DTLUP,CAT,DXCAT,PRI,ORD,LPRI
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQITRPRT",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITRPRT D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S NUM=$G(NUM,"")
S @DATA@(II)="T00030CATEGORY^T00030PROMPT^D00030DATE_LAST_UPDATED^T01024REMARK^I00003DISPLAY_ORDER"_$C(30)
;
;Do not display for deceased patients
S DOD=$$GET1^DIQ(2,DFN_",",.351,"I") I DOD]"" S II=II+1,@DATA@(II)=$C(31) Q
;
S TRIEN=0,CT=0,CAT="CVD-RELATED",DTLUP=$$GET1^DIQ(90507.5,DFN_",",.07,"I")
;
;Pull CVD-RELATED entries from ^BQIPAT
;
F S TRIEN=$O(^BQIPAT(DFN,50,TRIEN)) Q:'TRIEN D
. S PRI=$$GET1^DIQ(90508.5,TRIEN_",",.03,"I") Q:PRI=""
. S DXCAT=$$GET1^DIQ(90508.5,TRIEN_",",.02,"E") Q:DXCAT=""
. S TIT=$$GET1^DIQ(90508.5,TRIEN_",",.01,"E")
. S RMK=0,REMARK=""
. F S RMK=$O(^BQIPAT(DFN,50,TRIEN,1,RMK)) Q:'RMK D
.. S REMARK=REMARK_^BQIPAT(DFN,50,TRIEN,1,RMK,0)_" "
. S ORD(CAT,DXCAT,PRI)=CAT_U_TIT_U_$$FMTE^BQIUL1(DTLUP)_U_REMARK_U_PRI_$C(30)
;
; Check for other Treatment Prompts (note - there may be additional CVD-RELATED entries)
;
I $T(GVTP^APCHSMU)'="" D
. S TRIEN=0,DTLUP="",PRI=0
. F S TRIEN=$O(^APCHSURV(TRIEN)) Q:'TRIEN D
.. N ARRAY
.. I $P(^APCHSURV(TRIEN,0),U,7)'="T" Q
.. I $P(^APCHSURV(TRIEN,0),U,2)["BQITRASM" D VAR^BQIRMDR1
.. D GVTP^APCHSMU(DFN,TRIEN,80,.ARRAY)
.. I $P($G(ARRAY(0)),U)'=1 Q
.. S CAT=$$GET1^DIQ(9001018,TRIEN_",",.05,"E")
.. S DXCAT="",LPRI=$G(LPRI)+1
.. S TIT=$$GET1^DIQ(9001018,TRIEN_",",.01,"E")
.. S DXCAT=$$GET1^DIQ(9001018,TRIEN_",",.05,"E") Q:DXCAT=""
.. S RMK=0,REMARK=""
.. F S RMK=$O(ARRAY(RMK)) Q:RMK="" D
... S REMARK=REMARK_ARRAY(RMK)_" "
.. S PRI=PRI+1
.. S ORD(CAT,DXCAT,PRI)=CAT_U_TIT_U_$$FMTE^BQIUL1(DTLUP)_U_REMARK_U
;
;Process CVD-RELATED entries
S CAT="CVD-RELATED",LPRI=0
I $D(ORD(CAT)) D
. S DXFND="",CT=0
. F DXCAT="CVD-RELATED" D
.. S PRI="" F S PRI=$O(ORD(CAT,DXCAT,PRI)) Q:PRI="" D
... S CT=CT+1 I NUM'="",CT>NUM Q
... S LPRI=$S(PRI>LPRI:PRI,1:LPRI)
... I $E(ORD(CAT,DXCAT,PRI),$L(ORD(CAT,DXCAT,PRI)))'=$C(30) S ORD(CAT,DXCAT,PRI)=ORD(CAT,DXCAT,PRI)_$C(30)
... S II=II+1,@DATA@(II)=ORD(CAT,DXCAT,PRI)
. ;F DXCAT="CVD Known","CVD Highest Risk","CVD Significant Risk","CVD At Risk" D Q:DXFND
. F DXCAT="ASCVD Known","ASCVD At Risk" D Q:DXFND
.. S PRI="" F S PRI=$O(ORD(CAT,DXCAT,PRI)) Q:PRI="" D
... S CT=CT+1 I NUM'="",CT>NUM Q
... S LPRI=$S(PRI>LPRI:PRI,1:LPRI)
... S DXFND=1 ;Found an entry for this ASSOCIATED DX TAG
... I $E(ORD(CAT,DXCAT,PRI),$L(ORD(CAT,DXCAT,PRI)))'=$C(30) S ORD(CAT,DXCAT,PRI)=ORD(CAT,DXCAT,PRI)_$C(30)
... S II=II+1,@DATA@(II)=ORD(CAT,DXCAT,PRI)
. K ORD(CAT)
;
;Process other CAT entries
S CAT="" F S CAT=$O(ORD(CAT)) Q:CAT="" D
. S DXCAT="",CT=0 F S DXCAT=$O(ORD(CAT,DXCAT)) Q:DXCAT="" D
.. S PRI="" F S PRI=$O(ORD(CAT,DXCAT,PRI)) Q:PRI="" D
... S LPRI=LPRI+1,ORD(CAT,DXCAT,PRI)=ORD(CAT,DXCAT,PRI)_LPRI_$C(30)
... S CT=CT+1 I NUM'="",CT>NUM Q
... S II=II+1,@DATA@(II)=ORD(CAT,DXCAT,PRI)
;
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)=$C(31)
Q
BQITRPRT ;PRXM/HC/ALA-Get Treatment Prompts for a Patient ; 18 May 2007 12:05 PM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
+2 ;
EN(DATA,DFN,NUM) ;EP -- BQI PATIENT TRMT PROMPTS
+1 ; Input
+2 ; DFN - Patient internal entry number
+3 ;
+4 NEW DXCAT,DOD,DXFND,UID,II,CT,TRIEN,TIT,RMK,REMARK,DTLUP,CAT,DXCAT,PRI,ORD,LPRI
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BQITRPRT",UID))
+7 KILL @DATA
+8 SET II=0
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQITRPRT D UNWIND^%ZTER"
+10 ;
+11 SET NUM=$GET(NUM,"")
+12 SET @DATA@(II)="T00030CATEGORY^T00030PROMPT^D00030DATE_LAST_UPDATED^T01024REMARK^I00003DISPLAY_ORDER"_$CHAR(30)
+13 ;
+14 ;Do not display for deceased patients
+15 SET DOD=$$GET1^DIQ(2,DFN_",",.351,"I")
IF DOD]""
SET II=II+1
SET @DATA@(II)=$CHAR(31)
QUIT
+16 ;
+17 SET TRIEN=0
SET CT=0
SET CAT="CVD-RELATED"
SET DTLUP=$$GET1^DIQ(90507.5,DFN_",",.07,"I")
+18 ;
+19 ;Pull CVD-RELATED entries from ^BQIPAT
+20 ;
+21 FOR
SET TRIEN=$ORDER(^BQIPAT(DFN,50,TRIEN))
IF 'TRIEN
QUIT
Begin DoDot:1
+22 SET PRI=$$GET1^DIQ(90508.5,TRIEN_",",.03,"I")
IF PRI=""
QUIT
+23 SET DXCAT=$$GET1^DIQ(90508.5,TRIEN_",",.02,"E")
IF DXCAT=""
QUIT
+24 SET TIT=$$GET1^DIQ(90508.5,TRIEN_",",.01,"E")
+25 SET RMK=0
SET REMARK=""
+26 FOR
SET RMK=$ORDER(^BQIPAT(DFN,50,TRIEN,1,RMK))
IF 'RMK
QUIT
Begin DoDot:2
+27 SET REMARK=REMARK_^BQIPAT(DFN,50,TRIEN,1,RMK,0)_" "
End DoDot:2
+28 SET ORD(CAT,DXCAT,PRI)=CAT_U_TIT_U_$$FMTE^BQIUL1(DTLUP)_U_REMARK_U_PRI_$CHAR(30)
End DoDot:1
+29 ;
+30 ; Check for other Treatment Prompts (note - there may be additional CVD-RELATED entries)
+31 ;
+32 IF $TEXT(GVTP^APCHSMU)'=""
Begin DoDot:1
+33 SET TRIEN=0
SET DTLUP=""
SET PRI=0
+34 FOR
SET TRIEN=$ORDER(^APCHSURV(TRIEN))
IF 'TRIEN
QUIT
Begin DoDot:2
+35 NEW ARRAY
+36 IF $PIECE(^APCHSURV(TRIEN,0),U,7)'="T"
QUIT
+37 IF $PIECE(^APCHSURV(TRIEN,0),U,2)["BQITRASM"
DO VAR^BQIRMDR1
+38 DO GVTP^APCHSMU(DFN,TRIEN,80,.ARRAY)
+39 IF $PIECE($GET(ARRAY(0)),U)'=1
QUIT
+40 SET CAT=$$GET1^DIQ(9001018,TRIEN_",",.05,"E")
+41 SET DXCAT=""
SET LPRI=$GET(LPRI)+1
+42 SET TIT=$$GET1^DIQ(9001018,TRIEN_",",.01,"E")
+43 SET DXCAT=$$GET1^DIQ(9001018,TRIEN_",",.05,"E")
IF DXCAT=""
QUIT
+44 SET RMK=0
SET REMARK=""
+45 FOR
SET RMK=$ORDER(ARRAY(RMK))
IF RMK=""
QUIT
Begin DoDot:3
+46 SET REMARK=REMARK_ARRAY(RMK)_" "
End DoDot:3
+47 SET PRI=PRI+1
+48 SET ORD(CAT,DXCAT,PRI)=CAT_U_TIT_U_$$FMTE^BQIUL1(DTLUP)_U_REMARK_U
End DoDot:2
End DoDot:1
+49 ;
+50 ;Process CVD-RELATED entries
+51 SET CAT="CVD-RELATED"
SET LPRI=0
+52 IF $DATA(ORD(CAT))
Begin DoDot:1
+53 SET DXFND=""
SET CT=0
+54 FOR DXCAT="CVD-RELATED"
Begin DoDot:2
+55 SET PRI=""
FOR
SET PRI=$ORDER(ORD(CAT,DXCAT,PRI))
IF PRI=""
QUIT
Begin DoDot:3
+56 SET CT=CT+1
IF NUM'=""
IF CT>NUM
QUIT
+57 SET LPRI=$SELECT(PRI>LPRI:PRI,1:LPRI)
+58 IF $EXTRACT(ORD(CAT,DXCAT,PRI),$LENGTH(ORD(CAT,DXCAT,PRI)))'=$CHAR(30)
SET ORD(CAT,DXCAT,PRI)=ORD(CAT,DXCAT,PRI)_$CHAR(30)
+59 SET II=II+1
SET @DATA@(II)=ORD(CAT,DXCAT,PRI)
End DoDot:3
End DoDot:2
+60 ;F DXCAT="CVD Known","CVD Highest Risk","CVD Significant Risk","CVD At Risk" D Q:DXFND
+61 FOR DXCAT="ASCVD Known","ASCVD At Risk"
Begin DoDot:2
+62 SET PRI=""
FOR
SET PRI=$ORDER(ORD(CAT,DXCAT,PRI))
IF PRI=""
QUIT
Begin DoDot:3
+63 SET CT=CT+1
IF NUM'=""
IF CT>NUM
QUIT
+64 SET LPRI=$SELECT(PRI>LPRI:PRI,1:LPRI)
+65 ;Found an entry for this ASSOCIATED DX TAG
SET DXFND=1
+66 IF $EXTRACT(ORD(CAT,DXCAT,PRI),$LENGTH(ORD(CAT,DXCAT,PRI)))'=$CHAR(30)
SET ORD(CAT,DXCAT,PRI)=ORD(CAT,DXCAT,PRI)_$CHAR(30)
+67 SET II=II+1
SET @DATA@(II)=ORD(CAT,DXCAT,PRI)
End DoDot:3
End DoDot:2
IF DXFND
QUIT
+68 KILL ORD(CAT)
End DoDot:1
+69 ;
+70 ;Process other CAT entries
+71 SET CAT=""
FOR
SET CAT=$ORDER(ORD(CAT))
IF CAT=""
QUIT
Begin DoDot:1
+72 SET DXCAT=""
SET CT=0
FOR
SET DXCAT=$ORDER(ORD(CAT,DXCAT))
IF DXCAT=""
QUIT
Begin DoDot:2
+73 SET PRI=""
FOR
SET PRI=$ORDER(ORD(CAT,DXCAT,PRI))
IF PRI=""
QUIT
Begin DoDot:3
+74 SET LPRI=LPRI+1
SET ORD(CAT,DXCAT,PRI)=ORD(CAT,DXCAT,PRI)_LPRI_$CHAR(30)
+75 SET CT=CT+1
IF NUM'=""
IF CT>NUM
QUIT
+76 SET II=II+1
SET @DATA@(II)=ORD(CAT,DXCAT,PRI)
End DoDot:3
End DoDot:2
End DoDot:1
+77 ;
+78 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+79 QUIT
+80 ;
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)=$CHAR(31)
+6 QUIT
