BTPWTAX ;VNGT/HS/ALA-CMET Taxonomy List ; 05 Feb 2009 11:33 AM
;;1.2;CARE MANAGEMENT EVENT TRACKING;;Jul 07, 2017;Build 71
;
;
LST(DATA,PROC) ; EP -- BQI GET CMET TAXONOMY LIST
; Input
; PROC - Retrieves taxonomies for a particular CMET procedure.
; If left blank, it retrieves all taxonomies for CMET
;
NEW UID,II,TIEN,TTXT,TAXV,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BTPWTAX",UID))
K @DATA
;
S PROC=$G(PROC,"")
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWTAX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^T00030REGISTER^T00003USER_EDITABLE"_$C(30)
;
I PROC'="" D PRCS
;
I PROC="" D CMET
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
CMET ; EP
S PROC=0
F S PROC=$O(^BTPW(90621,PROC)) Q:'PROC D PRCS
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
;
PRCS ;
NEW TIEN,TDATA,TY,ID,IID,USER,CCAT,TTXT,TXTN
S TIEN=0
F S TIEN=$O(^BTPW(90621,PROC,1,TIEN)) Q:'TIEN D
. NEW DA,IENS
. S DA(1)=PROC,DA=TIEN,IENS=$$IENS^DILF(.DA)
. S TDATA=^BTPW(90621,PROC,1,TIEN,0)
. S ID="",TY=$P(TDATA,U,3),CAT="",USER="",IID=""
. I TY'="" S ID=$$GET1^DIQ(90621.1,TY,.06,"E"),CAT=$$GET1^DIQ(90621.1,TY,.07,"E"),IID=$$GET1^DIQ(90621.1,TY,.06,"I")
. S II=II+1
. S USER=$S(IID="CM":"YES",1:"NO")
. S CCAT=$$CAT^BTPWPDSP(PROC),CCAT=$$LOWER^VALM1(CCAT)
. S TTXT=$P(TDATA,U,1),TXTN=$P(TDATA,U,2),SITE=$S($$GET1^DIQ(90621.01,IENS,.04,"I")=1:"YES",1:"NO")
. S ITEM=$S('$$ENTRS^BQITAXX($P(TDATA,U,2)):"NO",1:"YES")
. S @SORT@(TTXT,CAT,ID)=TTXT_U_TXTN_U_CAT_U_SITE_U_ID_U_ITEM_U_CCAT_U_USER
. ;S @DATA@(II)=$P(TDATA,U,1)_U_$P(TDATA,U,2)_U_CAT
. ;S @DATA@(II)=@DATA@(II)_U_$S($$GET1^DIQ(90621.01,IENS,.04,"I")=1:"YES",1:"NO")_U_ID_U_$S('$$ENTRS^BQITAXX($P(TDATA,U,2)):"NO",1:"YES")_U_CCAT_U_USER_$C(30)
Q
;
ITM(DATA,TAXIEN,VDATE) ;EP - BTPW GET TAXONOMY ITEMS
NEW UID,II,TIEN,IEN,CODE,DESC,BTPWX,TAX,VALUE,N,HDR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BTPWTAXI",UID))
K @DATA
;
I $G(VDATE)'="" S VDATE=$$DATE^BQIUL1(VDATE)
I $G(VDATE)="" S VDATE=DT
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWTAX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
D ITM^BQITAXX5(.DATA,TAXIEN)
NEW VALUE,VVDATE,VVTYP,VVFIL,VVTN,VOK,CT,VVTYP1,VVTYP2,IMPL1,IMPL2
K BTPWX
S TIEN=0,HDR="I00010IVALIEN^T00080IVALDESC"
F S TIEN=$O(@DATA@(TIEN)) Q:'TIEN D
. I @DATA@(TIEN)[$C(31) Q
. S VALUE=$$TKO^BQIUL1(@DATA@(TIEN),$C(30))
. S VVDATE=$P(VALUE,U,11),VVDATE=$$DATE^BQIUL1(VVDATE)
. S VVTYP=$P(VALUE,U,10)
. ;
. I VVTYP["ICD" D Q
.. I VALUE=$C(31) Q
.. S VVFIL=$P(VALUE,U,2)
.. S VVTN="",VOK=0,CT=0 F S VVTN=$O(^ICDS("F",VVFIL,VVTN)) Q:VVTN="" D
... S CT=CT+1,@("IMPL"_CT)=$P(^ICDS(VVTN,0),"^",4),@("VVTYP"_CT)=$P(^ICDS(VVTN,0),"^",1)
.. I VDATE>IMPL2 D Q
... I VVTYP'=VVTYP2 Q
... D VOK
.. I VDATE<IMPL2,VDATE>IMPL1 D Q
... I VVDATE="",VVTYP=VVTYP1 D VOK Q
... I VDATE'>VVDATE D VOK Q
. ;
. I VVTYP="CPT" D Q
.. S VVTN=$P(VALUE,U,7),IMPL=$P(^ICPT(VVTN,0),U,8)
.. I VVDATE="",VDATE>IMPL D VOK Q
.. I VVDATE'="",VDATE<VVDATE,VDATE>IMPL D VOK Q
. ;
. D VOK
;
K @DATA
S @DATA@(II)=HDR_$C(30)
I TAXIEN["ATXLAB" S II=II+1,@DATA@(II)=" "_$C(30)
S N=0 F S N=$O(BTPWX(N)) Q:N="" S II=II+1,@DATA@(II)=BTPWX(N)
S II=II+1,@DATA@(II)=$C(31)
Q
;
VOK ;EP
S IEN=$P(VALUE,U,7),CODE=$P(VALUE,U,8),DESC=$P(VALUE,U,9)
S BTPWX(TIEN)=IEN_U_CODE_$S(CODE'="":" - ",1:"")_DESC_$C(30)
Q
BTPWTAX ;VNGT/HS/ALA-CMET Taxonomy List ; 05 Feb 2009 11:33 AM
+1 ;;1.2;CARE MANAGEMENT EVENT TRACKING;;Jul 07, 2017;Build 71
+2 ;
+3 ;
LST(DATA,PROC) ; EP -- BQI GET CMET TAXONOMY LIST
+1 ; Input
+2 ; PROC - Retrieves taxonomies for a particular CMET procedure.
+3 ; If left blank, it retrieves all taxonomies for CMET
+4 ;
+5 NEW UID,II,TIEN,TTXT,TAXV,X
+6 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+7 SET DATA=$NAME(^TMP("BTPWTAX",UID))
+8 KILL @DATA
+9 ;
+10 SET PROC=$GET(PROC,"")
+11 SET II=0
+12 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWTAX D UNWIND^%ZTER"
+13 ;
+14 SET @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^T00030REGISTER^T00003USER_EDITABLE"_$CHAR(30)
+15 ;
+16 IF PROC'=""
DO PRCS
+17 ;
+18 IF PROC=""
DO CMET
+19 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
CMET ; EP
+1 SET PROC=0
+2 FOR
SET PROC=$ORDER(^BTPW(90621,PROC))
IF 'PROC
QUIT
DO PRCS
+3 QUIT
+4 ;
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 ;
PRCS ;
+1 NEW TIEN,TDATA,TY,ID,IID,USER,CCAT,TTXT,TXTN
+2 SET TIEN=0
+3 FOR
SET TIEN=$ORDER(^BTPW(90621,PROC,1,TIEN))
IF 'TIEN
QUIT
Begin DoDot:1
+4 NEW DA,IENS
+5 SET DA(1)=PROC
SET DA=TIEN
SET IENS=$$IENS^DILF(.DA)
+6 SET TDATA=^BTPW(90621,PROC,1,TIEN,0)
+7 SET ID=""
SET TY=$PIECE(TDATA,U,3)
SET CAT=""
SET USER=""
SET IID=""
+8 IF TY'=""
SET ID=$$GET1^DIQ(90621.1,TY,.06,"E")
SET CAT=$$GET1^DIQ(90621.1,TY,.07,"E")
SET IID=$$GET1^DIQ(90621.1,TY,.06,"I")
+9 SET II=II+1
+10 SET USER=$SELECT(IID="CM":"YES",1:"NO")
+11 SET CCAT=$$CAT^BTPWPDSP(PROC)
SET CCAT=$$LOWER^VALM1(CCAT)
+12 SET TTXT=$PIECE(TDATA,U,1)
SET TXTN=$PIECE(TDATA,U,2)
SET SITE=$SELECT($$GET1^DIQ(90621.01,IENS,.04,"I")=1:"YES",1:"NO")
+13 SET ITEM=$SELECT('$$ENTRS^BQITAXX($PIECE(TDATA,U,2)):"NO",1:"YES")
+14 SET @SORT@(TTXT,CAT,ID)=TTXT_U_TXTN_U_CAT_U_SITE_U_ID_U_ITEM_U_CCAT_U_USER
+15 ;S @DATA@(II)=$P(TDATA,U,1)_U_$P(TDATA,U,2)_U_CAT
+16 ;S @DATA@(II)=@DATA@(II)_U_$S($$GET1^DIQ(90621.01,IENS,.04,"I")=1:"YES",1:"NO")_U_ID_U_$S('$$ENTRS^BQITAXX($P(TDATA,U,2)):"NO",1:"YES")_U_CCAT_U_USER_$C(30)
End DoDot:1
+17 QUIT
+18 ;
ITM(DATA,TAXIEN,VDATE) ;EP - BTPW GET TAXONOMY ITEMS
+1 NEW UID,II,TIEN,IEN,CODE,DESC,BTPWX,TAX,VALUE,N,HDR
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BTPWTAXI",UID))
+4 KILL @DATA
+5 ;
+6 IF $GET(VDATE)'=""
SET VDATE=$$DATE^BQIUL1(VDATE)
+7 IF $GET(VDATE)=""
SET VDATE=DT
+8 SET II=0
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWTAX D UNWIND^%ZTER"
+10 DO ITM^BQITAXX5(.DATA,TAXIEN)
+11 NEW VALUE,VVDATE,VVTYP,VVFIL,VVTN,VOK,CT,VVTYP1,VVTYP2,IMPL1,IMPL2
+12 KILL BTPWX
+13 SET TIEN=0
SET HDR="I00010IVALIEN^T00080IVALDESC"
+14 FOR
SET TIEN=$ORDER(@DATA@(TIEN))
IF 'TIEN
QUIT
Begin DoDot:1
+15 IF @DATA@(TIEN)[$CHAR(31)
QUIT
+16 SET VALUE=$$TKO^BQIUL1(@DATA@(TIEN),$CHAR(30))
+17 SET VVDATE=$PIECE(VALUE,U,11)
SET VVDATE=$$DATE^BQIUL1(VVDATE)
+18 SET VVTYP=$PIECE(VALUE,U,10)
+19 ;
+20 IF VVTYP["ICD"
Begin DoDot:2
+21 IF VALUE=$CHAR(31)
QUIT
+22 SET VVFIL=$PIECE(VALUE,U,2)
+23 SET VVTN=""
SET VOK=0
SET CT=0
FOR
SET VVTN=$ORDER(^ICDS("F",VVFIL,VVTN))
IF VVTN=""
QUIT
Begin DoDot:3
+24 SET CT=CT+1
SET @("IMPL"_CT)=$PIECE(^ICDS(VVTN,0),"^",4)
SET @("VVTYP"_CT)=$PIECE(^ICDS(VVTN,0),"^",1)
End DoDot:3
+25 IF VDATE>IMPL2
Begin DoDot:3
+26 IF VVTYP'=VVTYP2
QUIT
+27 DO VOK
End DoDot:3
QUIT
+28 IF VDATE<IMPL2
IF VDATE>IMPL1
Begin DoDot:3
+29 IF VVDATE=""
IF VVTYP=VVTYP1
DO VOK
QUIT
+30 IF VDATE'>VVDATE
DO VOK
QUIT
End DoDot:3
QUIT
End DoDot:2
QUIT
+31 ;
+32 IF VVTYP="CPT"
Begin DoDot:2
+33 SET VVTN=$PIECE(VALUE,U,7)
SET IMPL=$PIECE(^ICPT(VVTN,0),U,8)
+34 IF VVDATE=""
IF VDATE>IMPL
DO VOK
QUIT
+35 IF VVDATE'=""
IF VDATE<VVDATE
IF VDATE>IMPL
DO VOK
QUIT
End DoDot:2
QUIT
+36 ;
+37 DO VOK
End DoDot:1
+38 ;
+39 KILL @DATA
+40 SET @DATA@(II)=HDR_$CHAR(30)
+41 IF TAXIEN["ATXLAB"
SET II=II+1
SET @DATA@(II)=" "_$CHAR(30)
+42 SET N=0
FOR
SET N=$ORDER(BTPWX(N))
IF N=""
QUIT
SET II=II+1
SET @DATA@(II)=BTPWX(N)
+43 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+44 QUIT
+45 ;
VOK ;EP
+1 SET IEN=$PIECE(VALUE,U,7)
SET CODE=$PIECE(VALUE,U,8)
SET DESC=$PIECE(VALUE,U,9)
+2 SET BTPWX(TIEN)=IEN_U_CODE_$SELECT(CODE'="":" - ",1:"")_DESC_$CHAR(30)
+3 QUIT
