Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQITRCTB

BQITRCTB.m

Go to the documentation of this file. 
  1. BQITRCTB ;GDHD/HS/ALA-CVD Tobacco ; 16 Jun 2016  3:16 PM
  1.  ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
  1.  ;
  1. ASSES(BQDFN) ;EP - Assessed Tobacco
  1.  NEW MEET,DESC,X,TAX,TREF
  1.  S MEET=1,DESC="No Tobacco Assessment in past year"
  1.  S X=$$TOB^BQIRGASU(BQDFN)
  1.  I X D
  1.  . S $P(X,U,2)=$$DATE^BQIUL1($P(X,U,2))
  1.  . S MEET=0,DESC="Last Tobacco HF was "_$$FMTMDY^BQIUL1($P(X,U,2))
  1.  I X="" D
  1.  . ;Patient Education Code
  1.  . S BQTDATE=$$DATE^BQIUL1("T-12M"),RESULT=1
  1.  . I $$FED^BQITREDU(BQTDATE,BQDFN,"TO-") S MEET=0,DESC="Patient met education code 'TO-'"
  1.  . I $$FED^BQITREDU(BQTDATE,BQDFN,"-TO") S MEET=0,DESC="Patient met education code '-TO'"
  1.  . I $$FED^BQITREDU(BQTDATE,BQDFN,"-SHS") S MEET=0,DESC="Patient met education code '-SHS'"
  1.  . S SN=$O(^BGPSNOMM("B","TOBACCO SCREEN PATIENT ED",0))
  1.  . I SN'="" D
  1.  .. S CD=0 F  S CD=$O(^BGPSNOMM(SN,11,CD)) Q:'CD  D
  1.  ... S SNOM=^BGPSNOMM(SN,11,CD,0)
  1.  ... I $$FED^BQITREDU(BQTDATE,BQDFN,SNOM) S MEET=0,DESC="Patient met SNOMED subset TOBACCO SCREEN PATIENT ED" Q
  1.  . ;
  1.  . S TAX="BGP TOBACCO DXS",TREF=$NA(^TMP("BQITAX",UID)) K @TREF
  1.  . D BLD^BQITUTL(TAX,.TREF)
  1.  . S N="" F  S N=$O(@TREF@(N)) Q:N=""  S DXC=$P(@TREF@(N),"^",1) D
  1.  .. I $$FED^BQITREDU(BQTDATE,BQDFN,DXC) S MEET=0,DESC="Patient met taxonomy BGP TOBACCO DXS" Q
  1.  . ;
  1.  . S TAX="BGP TOBACCO SCREEN CPTS",TREF=$NA(^TMP("BQITAX",UID)) K @TREF
  1.  . D BLD^BQITUTL(TAX,.TREF)
  1.  . S N="" F  S N=$O(@TREF@(N)) Q:N=""  S CPT=$P(@TREF@(N),"^",1) D
  1.  .. I $$FED^BQITREDU(BQTDATE,BQDFN,CPT) S MEET=0,DESC="Patient met education BGP TOBACCO SCREEN CPTS" Q
  1.  . ;
  1.  . S N="" F  S N=$O(@TREF@(N)) Q:N=""  S CPT=$P(@TREF@(N),"^",1) D
  1.  .. I $$TAX^BQITRUTL("T-12M","",1,BQDFN,9000010.18,"",,.TREF,"","") S MEET=0,DESC="Patient met CPT BGP TOBACCO SCREEN CPTS" Q
  1.  ;
  1.  Q MEET_U_DESC
  1.  ;
  1. EDUC ;EP - Education
  1.  S MEET=1,DESC="No Tobacco Intervention"
  1.  I $$FED^BQITREDU(BQTDATE,BQDFN,"TO-") S MEET=0,DESC="Patient met education code 'TO-'"
  1.  I $$FED^BQITREDU(BQTDATE,BQDFN,"-TO") S MEET=0,DESC="Patient met education code '-TO'"
  1.  I $$FED^BQITREDU(BQTDATE,BQDFN,"-SHS") S MEET=0,DESC="Patient met education code '-SHS'"
  1.  S SN=$O(^BGPSNOMM("B","TOBACCO SCREEN PATIENT ED",0))
  1.  I SN'="" D
  1.  . S CD=0 F  S CD=$O(^BGPSNOMM(SN,11,CD)) Q:'CD  D
  1.  .. S SNOM=^BGPSNOMM(SN,11,CD,0)
  1.  .. I $$FED^BQITREDU(BQTDATE,BQDFN,SNOM) S MEET=0,DESC="Patient met SNOMED subset TOBACCO SCREEN PATIENT ED" Q
  1.  ;
  1.  S TAX="BGP TOBACCO DXS",TREF=$NA(^TMP("BQITAX",UID)) K @TREF
  1.  D BLD^BQITUTL(TAX,.TREF)
  1.  S N="" F  S N=$O(@TREF@(N)) Q:N=""  S DXC=$P(@TREF@(N),"^",1) D
  1.  . I $$FED^BQITREDU(BQTDATE,BQDFN,DXC) S MEET=0,DESC="Patient met taxonomy BGP TOBACCO DXS" Q
  1.  ;
  1.  S TAX="BGP TOBACCO SCREEN CPTS",TREF=$NA(^TMP("BQITAX",UID)) K @TREF
  1.  D BLD^BQITUTL(TAX,.TREF)
  1.  S N="" F  S N=$O(@TREF@(N)) Q:N=""  S CPT=$P(@TREF@(N),"^",1) D
  1.  . I $$FED^BQITREDU(BQTDATE,BQDFN,CPT) S MEET=0,DESC="Patient met education BGP TOBACCO SCREEN CPTS" Q
  1.  Q
  1.  ;
  1. SMOK(BQDFN) ; EP - Find smoking for a patient
  1.  ; Input
  1.  ;   BQDFN - Patient internal entry number
  1.  ;
  1.  NEW BQIARRAY,BA,LBA,NP,VIEN,VDATE,BQDEF,BQEXEC,BQGLB,BQIRY,ENDT
  1.  NEW EXDT,PLFLG,RESULT,TMREF,TOB,TPIEN,MTYP,DNC,BQTDATE,QFL,TAX
  1.  NEW TCC,VISIT
  1.  S UID=$G(UID,$J),RESULT=""
  1.  S TMREF=$NA(^TMP("BQITOBAC",UID)) K @TMREF
  1.  ; if patient current tobacco user
  1.  S TOB=$$PAT^BQITD12("Tobacco Users (Smokers)","BQIARRAY",BQDFN)
  1.  I TOB D
  1.  . S BA="BQIARRAY" F  S BA=$Q(@BA) Q:BA=""  S LBA=BA
  1.  . S NP=$L(LBA,",")
  1.  . I $F(LBA,",""P"",") S TPIEN=$P($P(LBA,",",NP),")",1) S BQTDATE=$$PROB^BQIUL1(TPIEN)
  1.  . I $F(LBA,",""V"",") S VIEN=$P($P(LBA,",",NP-1),")",1) S BQTDATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)\1
  1.  . M @TMREF=BQIARRAY
  1.  . S RESULT="Patient tagged as current tobacco user"
  1.  ;
  1.  I 'TOB D
  1.  . ; Check for new CPT taxonomy
  1.  . S TREF=$NA(^TMP("BQITAX",UID)) K @TREF
  1.  . D BLD^BQITUTL("BGP TOBACCO USER CPTS",TREF)
  1.  . S IEN=""
  1.  . F  S IEN=$O(^AUPNVCPT("AC",BQDFN,IEN),-1) Q:IEN=""  D
  1.  .. S TIEN=$$GET1^DIQ(9000010.18,IEN,.01,"I") I TIEN="" Q
  1.  .. I '$D(@TREF@(TIEN)) Q
  1.  .. S VIEN=$$GET1^DIQ(9000010.18,IEN,.03,"I") Q:VIEN=""
  1.  .. I $$GET1^DIQ(9000010,VIEN,.11,"I")=1 Q
  1.  .. S VDATE=$$GET1^DIQ(9000010,VIEN,.01,"I")\1 Q:'VDATE
  1.  .. S @TMREF@(VDATE,IEN)=VIEN,TOB=1,RESULT="Patient had a CPT from BGP TOBACCO USER CPTS"
  1.  ;
  1.  ; If not current tobacco user, quit
  1.  I 'TOB Q 0_"^Patient not a current tobacco user"
  1.  ;
  1.  I $G(BQTDATE)="" S BQTDATE=$O(@TMREF@(""),-1)
  1.  ;
  1.  ; if current tobacco user, check for tobacco intervention
  1.  S TREF=$NA(^TMP("BQITAX",UID)) K @TREF
  1.  D BLD^BQITUTL("BGP TOBACCO INTERVENTION CPTS",TREF)
  1.  S IEN="",QFL=0
  1.  F  S IEN=$O(^AUPNVCPT("AC",BQDFN,IEN),-1) Q:IEN=""  D  Q:QFL
  1.  . S TIEN=$$GET1^DIQ(9000010.18,IEN,.01,"I") I TIEN="" Q
  1.  . I '$D(@TREF@(TIEN)) Q
  1.  . S VIEN=$$GET1^DIQ(9000010.18,IEN,.03,"I") Q:VIEN=""
  1.  . I $$GET1^DIQ(9000010,VIEN,.11,"I")=1 Q
  1.  . S VDATE=$$GET1^DIQ(9000010,VIEN,.01,"I")\1 Q:'VDATE
  1.  . I VDATE'>BQTDATE Q
  1.  . S QFL=1
  1.  I QFL Q 0_"^Patient had tobacco intervention CPT from BGP TOBACCO INTERVENTION CPTS"
  1.  ;
  1.  ; If intervention has been documented after most recent tobacco use
  1.  D EDUC I 'MEET Q "0^"_DESC
  1.  ;Dental Code
  1.  S DNC=$$FIND1^DIC(9999999.31,"","X",1320,"B","","ERROR")
  1.  S QFL=0
  1.  I DNC'="" D
  1.  . S IEN=""
  1.  . F  S IEN=$O(^AUPNVDEN("B",DNC,IEN)) Q:IEN=""  D  Q:QFL
  1.  .. I $$GET1^DIQ(9000010.05,IEN,.02,"I")'=BQDFN Q
  1.  .. S VISIT=$$GET1^DIQ(9000010.05,IEN,.03,"I") Q:VISIT=""
  1.  .. I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
  1.  .. S VDATE=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:'VDATE
  1.  .. I VDATE<BQTDATE Q
  1.  .. S QFL=1
  1.  I QFL Q 0_"^Patient met Dental Code 1320"
  1.  ;
  1.  ;Clinic Code 94
  1.  S TCC=$$FIND1^DIC(40.7,"","X",94,"C","","ERROR")
  1.  S VISIT="",QFL=0
  1.  F  S VISIT=$O(^AUPNVSIT("AC",BQDFN,VISIT)) Q:VISIT=""  D  Q:QFL
  1.  . I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
  1.  . S VDATE=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:'VDATE
  1.  . I VDATE<BQTDATE Q
  1.  . I $$GET1^DIQ(9000010,VISIT,.08,"I")'=TCC Q
  1.  . S QFL=1
  1.  I QFL Q 0_"^Patient had a visit in TOBACCO CESSATION CLINIC"
  1.  ;
  1.  ;Medication with Name containing
  1.  S TREF=$NA(^TMP("BQITAX",UID)) K @TREF
  1.  F TAX="BGP CMS SMOKING CESSATION MEDS","BGP CMS SMOKING CESSATION NDC" D BLD^BQITUTL("BGP TOBACCO USER CPTS",TREF)
  1.  F MTYP="NICOTINE PATCH","NICOTINE POLACRILEX","NICOTINE INHALER","NICOTINE NASAL SPRAY" D MED^BQITRUTL(TREF,MTYP)
  1.  S TIEN="",QFL=0
  1.  F  S TIEN=$O(@TREF@(TIEN)) Q:TIEN=""  D  Q:QFL
  1.  . S IEN=""
  1.  . F  S IEN=$O(^AUPNVMED("B",TIEN,IEN)) Q:IEN=""  D  Q:QFL
  1.  .. I $$GET1^DIQ(9000010.14,IEN,.02,"I")'=BQDFN Q
  1.  .. S VISIT=$$GET1^DIQ(9000010.14,IEN,.03,"I") Q:VISIT=""
  1.  .. I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
  1.  .. S VDATE=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:'VDATE
  1.  .. I VDATE<BQTDATE Q
  1.  .. S QFL=1
  1.  I QFL Q 0_"^Patient had smoking cessation medication"
  1.  ;
  1.  Q 1_"^Patient current smoker but no smoking cessation intervention"