- 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
