BQIMTCRT ;GDIT/HS/ALA-Matched Criteria Utilities ; 23 Jan 2013 12:42 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
;
TAB(DATA,OWNR,PLIEN) ;EP -- BQI GET MATCH CRITERIA DROP
NEW UID,II
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIMTCRT",UID))
K @DATA
;
S II=0
D THDR
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMTCRT D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
I $P(^BQICARE(OWNR,1,PLIEN,0),U,10)=0 G DONE
NEW DA,IENS,TYPE,SOURCE,FSOURCE,PPIEN,ARRAY
S DA(1)=OWNR,DA=PLIEN,IENS=$$IENS^DILF(.DA)
S SOURCE=$$GET1^DIQ(90505.01,IENS,.11,"E")
I SOURCE="INPATIENTS" S ARRAY("IN")="IN^Inpatients"
I SOURCE="ER VISITS" S ARRAY("ER")="ER^ER Visits"
;I SOURCE="RPMS REGISTER PATIENTS" S ARRAY("RG")="RG^Register"
S FSOURCE=$$GET1^DIQ(90505.01,IENS,.14,"E")
S PPIEN=$$PP^BQIDCDF(FSOURCE) I PPIEN=-1 G CONT
;
F TYPE="PROB","MED","LAB","ALLERGY","MEDTX","LABTX","PROBTX","CPT","CPTTX","EDUPICK","EDUTX","EDUC","EDUTOP","REMCODE","POV","POVTX","POVS","POVSB","MEAS" D
. I '$D(^BQICARE(OWNR,1,PLIEN,15,"B",TYPE)) Q
. I TYPE="PROB"!(TYPE="PROBTX") S ARRAY("PR")="PR^Problems"
. I TYPE="POV"!(TYPE="POVS")!(TYPE="POVTX")!(TYPE="POVSB") S ARRAY("DX")="DX^POVs"
. I TYPE="MEAS" S ARRAY("MS")="MS^Measurements"
. I TYPE="MED"!(TYPE="MEDTX") D
.. I $D(^BQICARE(OWNR,1,PLIEN,15,"B","MNOT")) Q
.. S ARRAY("ME")="ME^Medications"
. I TYPE="LAB"!(TYPE="LABTX") D
.. I $D(^BQICARE(OWNR,1,PLIEN,15,"B","LNOT")) Q
.. S ARRAY("LA")="LA^Lab Tests"
. I TYPE="ALLERGY" S ARRAY("AL")="AL^Allergies"
. I TYPE="CPT"!(TYPE="CPTTX") D
.. I $D(^BQICARE(OWNR,1,PLIEN,15,"B","CNOT")) Q
.. S ARRAY("CP")="CP^CPTs"
. I TYPE="EDUC"!(TYPE="EDUPICK")!(TYPE="EDUTX")!(TYPE="EDUTOP") D
.. I $D(^BQICARE(OWNR,1,PLIEN,15,"B","EDUNOT")) Q
.. S ARRAY("ED")="ED^Pt Education"
. I TYPE="REMCODE" S ARRAY("RE")="RE^Reminder Notifications"
;
CONT ;
NEW TIEN
S TYPE=""
F S TYPE=$O(ARRAY(TYPE)) Q:TYPE="" D
. S TIEN=$O(^BQI(90506.5,"C",TYPE,"")) I TIEN="" Q
. I $P(^BQI(90506.5,TIEN,0),"^",10)=1 Q
. S II=II+1,@DATA@(II)=ARRAY(TYPE)_$C(30)
;
DONE ;
I '$G(NFLG) 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
;
THDR ;
S @DATA@(II)="T00010IEN^T00030NAME"_$C(30)
Q
;
;
COL(DATA,TYPE) ;EP -- BQI GET MATCH CRITERIA COLUMN
NEW UID,II
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIMTCRT",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMTCRT D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;S MTYP=$S(TYPE="PR":"PROB",TYPE="ME":"MED",TYPE="LA":"LAB",TYPE="IN":"INP",TYPE="CP":"CPT",TYPE="AL":"ALGY",1:"") I MTYP="" Q
S HDR="T00015CODE^T00050DISPLAY_NAME"
S @DATA@(II)=HDR_$C(30)
;
NEW CRIEN,TYP,ORD,IEN,KEY,CODE
S CRIEN=$$FIND1^DIC(90506.5,"","B","Patient","","","ERROR")
S TYP=$P(^BQI(90506.5,CRIEN,0),U,2)
S ORD=""
F S ORD=$O(^BQI(90506.1,"AD",TYP,ORD)) Q:ORD="" D
. S IEN=""
. F S IEN=$O(^BQI(90506.1,"AD",TYP,ORD,IEN)) Q:IEN="" D
.. I $$GET1^DIQ(90506.1,IEN_",",.1,"I")=1 Q
.. S KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
.. I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
.. I $$GET1^DIQ(90506.1,IEN_",",3.04,"I")'="O" D
... S CODE=$P(^BQI(90506.1,IEN,0),U,1) Q:CODE=""
... I $P($G(^BQI(90506.1,IEN,0)),U,10)=1 Q
... S II=II+1,@DATA@(II)=CODE_U_$P(^BQI(90506.1,IEN,0),U,3)_$C(30)
;
NEW CRIEN,BN,CDATA,CODE
S CRIEN=$$FIND1^DIC(90506.5,,"X",TYPE,"C","","ERROR")
S BN=0
F S BN=$O(^BQI(90506.5,CRIEN,10,BN)) Q:'BN D
. S CDATA=^BQI(90506.5,CRIEN,10,BN,0)
. S CODE=$P(CDATA,U,1)
. S II=II+1,@DATA@(II)=CODE_U_$P(CDATA,U,3)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
BQIMTCRT ;GDIT/HS/ALA-Matched Criteria Utilities ; 23 Jan 2013 12:42 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 ;
TAB(DATA,OWNR,PLIEN) ;EP -- BQI GET MATCH CRITERIA DROP
+1 NEW UID,II
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIMTCRT",UID))
+4 KILL @DATA
+5 ;
+6 SET II=0
+7 DO THDR
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIMTCRT D UNWIND^%ZTER"
+9 ;
+10 IF $PIECE(^BQICARE(OWNR,1,PLIEN,0),U,10)=0
GOTO DONE
+11 NEW DA,IENS,TYPE,SOURCE,FSOURCE,PPIEN,ARRAY
+12 SET DA(1)=OWNR
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
+13 SET SOURCE=$$GET1^DIQ(90505.01,IENS,.11,"E")
+14 IF SOURCE="INPATIENTS"
SET ARRAY("IN")="IN^Inpatients"
+15 IF SOURCE="ER VISITS"
SET ARRAY("ER")="ER^ER Visits"
+16 ;I SOURCE="RPMS REGISTER PATIENTS" S ARRAY("RG")="RG^Register"
+17 SET FSOURCE=$$GET1^DIQ(90505.01,IENS,.14,"E")
+18 SET PPIEN=$$PP^BQIDCDF(FSOURCE)
IF PPIEN=-1
GOTO CONT
+19 ;
+20 FOR TYPE="PROB","MED","LAB","ALLERGY","MEDTX","LABTX","PROBTX","CPT","CPTTX","EDUPICK","EDUTX","EDUC","EDUTOP","REMCODE","POV","POVTX","POVS","POVSB","MEAS"
Begin DoDot:1
+21 IF '$DATA(^BQICARE(OWNR,1,PLIEN,15,"B",TYPE))
QUIT
+22 IF TYPE="PROB"!(TYPE="PROBTX")
SET ARRAY("PR")="PR^Problems"
+23 IF TYPE="POV"!(TYPE="POVS")!(TYPE="POVTX")!(TYPE="POVSB")
SET ARRAY("DX")="DX^POVs"
+24 IF TYPE="MEAS"
SET ARRAY("MS")="MS^Measurements"
+25 IF TYPE="MED"!(TYPE="MEDTX")
Begin DoDot:2
+26 IF $DATA(^BQICARE(OWNR,1,PLIEN,15,"B","MNOT"))
QUIT
+27 SET ARRAY("ME")="ME^Medications"
End DoDot:2
+28 IF TYPE="LAB"!(TYPE="LABTX")
Begin DoDot:2
+29 IF $DATA(^BQICARE(OWNR,1,PLIEN,15,"B","LNOT"))
QUIT
+30 SET ARRAY("LA")="LA^Lab Tests"
End DoDot:2
+31 IF TYPE="ALLERGY"
SET ARRAY("AL")="AL^Allergies"
+32 IF TYPE="CPT"!(TYPE="CPTTX")
Begin DoDot:2
+33 IF $DATA(^BQICARE(OWNR,1,PLIEN,15,"B","CNOT"))
QUIT
+34 SET ARRAY("CP")="CP^CPTs"
End DoDot:2
+35 IF TYPE="EDUC"!(TYPE="EDUPICK")!(TYPE="EDUTX")!(TYPE="EDUTOP")
Begin DoDot:2
+36 IF $DATA(^BQICARE(OWNR,1,PLIEN,15,"B","EDUNOT"))
QUIT
+37 SET ARRAY("ED")="ED^Pt Education"
End DoDot:2
+38 IF TYPE="REMCODE"
SET ARRAY("RE")="RE^Reminder Notifications"
End DoDot:1
+39 ;
CONT ;
+1 NEW TIEN
+2 SET TYPE=""
+3 FOR
SET TYPE=$ORDER(ARRAY(TYPE))
IF TYPE=""
QUIT
Begin DoDot:1
+4 SET TIEN=$ORDER(^BQI(90506.5,"C",TYPE,""))
IF TIEN=""
QUIT
+5 IF $PIECE(^BQI(90506.5,TIEN,0),"^",10)=1
QUIT
+6 SET II=II+1
SET @DATA@(II)=ARRAY(TYPE)_$CHAR(30)
End DoDot:1
+7 ;
DONE ;
+1 IF '$GET(NFLG)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
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
+7 ;
THDR ;
+1 SET @DATA@(II)="T00010IEN^T00030NAME"_$CHAR(30)
+2 QUIT
+3 ;
+4 ;
COL(DATA,TYPE) ;EP -- BQI GET MATCH CRITERIA COLUMN
+1 NEW UID,II
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIMTCRT",UID))
+4 KILL @DATA
+5 ;
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIMTCRT D UNWIND^%ZTER"
+8 ;S MTYP=$S(TYPE="PR":"PROB",TYPE="ME":"MED",TYPE="LA":"LAB",TYPE="IN":"INP",TYPE="CP":"CPT",TYPE="AL":"ALGY",1:"") I MTYP="" Q
+9 SET HDR="T00015CODE^T00050DISPLAY_NAME"
+10 SET @DATA@(II)=HDR_$CHAR(30)
+11 ;
+12 NEW CRIEN,TYP,ORD,IEN,KEY,CODE
+13 SET CRIEN=$$FIND1^DIC(90506.5,"","B","Patient","","","ERROR")
+14 SET TYP=$PIECE(^BQI(90506.5,CRIEN,0),U,2)
+15 SET ORD=""
+16 FOR
SET ORD=$ORDER(^BQI(90506.1,"AD",TYP,ORD))
IF ORD=""
QUIT
Begin DoDot:1
+17 SET IEN=""
+18 FOR
SET IEN=$ORDER(^BQI(90506.1,"AD",TYP,ORD,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+19 IF $$GET1^DIQ(90506.1,IEN_",",.1,"I")=1
QUIT
+20 SET KEY=$$GET1^DIQ(90506.1,IEN_",",3.1,"E")
+21 IF KEY'=""
IF '$$KEYCHK^BQIULSC(KEY,DUZ)
QUIT
+22 IF $$GET1^DIQ(90506.1,IEN_",",3.04,"I")'="O"
Begin DoDot:3
+23 SET CODE=$PIECE(^BQI(90506.1,IEN,0),U,1)
IF CODE=""
QUIT
+24 IF $PIECE($GET(^BQI(90506.1,IEN,0)),U,10)=1
QUIT
+25 SET II=II+1
SET @DATA@(II)=CODE_U_$PIECE(^BQI(90506.1,IEN,0),U,3)_$CHAR(30)
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;
+27 NEW CRIEN,BN,CDATA,CODE
+28 SET CRIEN=$$FIND1^DIC(90506.5,,"X",TYPE,"C","","ERROR")
+29 SET BN=0
+30 FOR
SET BN=$ORDER(^BQI(90506.5,CRIEN,10,BN))
IF 'BN
QUIT
Begin DoDot:1
+31 SET CDATA=^BQI(90506.5,CRIEN,10,BN,0)
+32 SET CODE=$PIECE(CDATA,U,1)
+33 SET II=II+1
SET @DATA@(II)=CODE_U_$PIECE(CDATA,U,3)_$CHAR(30)
End DoDot:1
+34 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+35 QUIT
