- 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
