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

BKMSTI.m

Go to the documentation of this file. 
  1. BKMSTI ;PRXM/HC/ALA - Sexually Transmitted Infection Screening ; 12 Mar 2007  1:52 PM
  1.  ;;2.1;HIV MANAGEMENT SYSTEM;**1,2**;Feb 07, 2011;Build 11
  1.  ;
  1.  ;
  1. EN(BKMDFN,BKBDT,BKEDT,TYPE,VALUE,HVDFL) ;EP
  1.  ;
  1.  ; Input
  1.  ;   BKMDFN - Patient internal entry number
  1.  ;   BRDT   - CRS Report Period begin date
  1.  ;   ERDT   - CRS Report Period end date (not used at this time because of the 300
  1.  ;            day limitation see BKEDT below)
  1.  ;   TYPE   - Type of STI (can be an individual one such as CHLAMYDIA, etc.;
  1.  ;            those 'KEY' STIs or 'OTHER' STIs as defined in the HMS STI SCREENING
  1.  ;            File #90454)
  1.  ;   VALUE  - The name of the array to return the data in
  1.  ;   HVDFL  - The HIV Diagnosis contraindication flag
  1.  ;   
  1.  ; Output
  1.  ;   VALUE  - structure is
  1.  ;            STI is the sexual transmitted infection code
  1.  ;            "DEN" is denominator data
  1.  ;            "NUM" is numerator data
  1.  ;            "REF" is refusal data
  1.  ;            SCSTI is the screening STI code
  1.  ;            # of incidences found within a 2-month period
  1.  ;               0 is no incidences found
  1.  ;               otherwise is number found within date range
  1.  ;            (STI,"DEN")=#^date diagnosis;
  1.  ;            STI,"NUM",SCSTI)=#^screening information
  1.  ;            STI,"REF",SCSTI)=#^refusal information
  1.  ;
  1.  NEW BKMIEN,BKDEN,ARRAY,BKTY,IEN,STIEN,BKPER,BKREF,BKNMTY,BKDATE
  1.  NEW BKMEDT,GLOBAL,IDATE,PDATE,IDXDT,LDATE,LIEN,LV,NDATE,NR,NXDT,PDATE,OFLG
  1.  NEW OR,PR,ODATE,VISIT,VSDT,QFL,RIEN,RTY
  1.  ;
  1.  ;  Set beginning date to 2 months (60 days) prior to CRS report period begin date
  1.  ;  through the first 300 days of the CRS report period
  1.  K ARRAY,ZARRAY
  1.  ;
  1.  ;  Check if passed a specific STI
  1.  S BKMIEN=$$FIND1^DIC(90454,,"MX",TYPE)
  1.  I BKMIEN D
  1.  . S BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
  1.  . ; Get the denominator executable
  1.  . S BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
  1.  . ;
  1.  . X BKDEN
  1.  . ; if no data, then the denominator should be zero
  1.  . I '$D(ARRAY) S VALUE(BKTY,"DEN")=0 Q
  1.  . ; find any numerator or refusal information
  1.  . D FND
  1.  ;
  1.  ; Only pull the key information
  1.  I TYPE="KEY" D
  1.  . S BKMIEN=""
  1.  . F  S BKMIEN=$O(^BKM(90454,"C","K",BKMIEN)) Q:BKMIEN=""  D
  1.  .. S BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
  1.  .. S BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
  1.  .. ; Denominator code
  1.  .. X BKDEN
  1.  .. ; if no data, then the denominator should be zero
  1.  .. I '$D(ARRAY) S VALUE(BKTY,"DEN")=0 Q
  1.  .. ; find any numerator or refusal information
  1.  .. D FND
  1.  ;
  1.  ; Only pull the other STIs
  1.  I TYPE="OTHER" D
  1.  . S BKMIEN=""
  1.  . F  S BKMIEN=$O(^BKM(90454,"C","O",BKMIEN)) Q:BKMIEN=""  D
  1.  .. S BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
  1.  .. S BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
  1.  .. ; Denominator code
  1.  .. X BKDEN
  1.  .. ; if no data, then the denominator should be zero
  1.  .. I '$D(ARRAY) S VALUE(BKTY,"DEN")=0 Q
  1.  .. ; find any numerator or refusal information
  1.  .. D FND
  1.  ;
  1.  ; Pull all STIs
  1.  I TYPE="" D
  1.  . S BKMIEN=0
  1.  . F  S BKMIEN=$O(^BKM(90454,BKMIEN)) Q:'BKMIEN  D
  1.  .. S BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
  1.  .. S BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
  1.  .. ; Denominator code
  1.  .. X BKDEN
  1.  .. ; if no data, then the denominator should be zero
  1.  .. I '$D(ARRAY) S VALUE(BKTY,"DEN")=0 Q
  1.  .. ; find any numerator or refusal information
  1.  .. D FND
  1.  Q
  1.  ;
  1. FND ;  Find numerator data for all associated screenings
  1.  ; Parameters
  1.  ;   BKPER - Performance executable
  1.  ;   BKREF - Refusal executable
  1.  ;
  1.  S IEN=0
  1.  F  S IEN=$O(^BKM(90454,BKMIEN,10,IEN)) Q:'IEN  D
  1.  . S STIEN=$P(^BKM(90454,BKMIEN,10,IEN,0),U,1)
  1.  . S BKPER=$$GET1^DIQ(90454,STIEN_",",2,"E")
  1.  . S BKREF=$$GET1^DIQ(90454,STIEN_",",3,"E")
  1.  . S BKNMTY=$$GET1^DIQ(90454,STIEN_",",.03,"E")
  1.  . ;   For each denominator date
  1.  . S BKDATE=""
  1.  . F  S BKDATE=$O(ARRAY(BKTY,BKDATE)) Q:BKDATE=""  D
  1.  .. NEW EDATE,BDATE
  1.  .. ; Check for performance of a screen 30 days prior and 2 months after
  1.  .. ; the denominator date
  1.  .. ;S EDATE=$$FMADD^XLFDT(BKDATE,60),BDATE=$$FMADD^XLFDT(BKDATE,-30)
  1.  .. S EDATE=$$FMADD^XLFDT(BKDATE,(30.4167*2)),BDATE=$$FMADD^XLFDT(BKDATE,-30.4167)
  1.  .. X BKPER
  1.  .. I '$D(VALUE(BKTY,"NUM",BKNMTY)) S VALUE(BKTY,"NUM",BKNMTY)=0
  1.  .. I $D(VALUE(BKTY,"NUM",BKNMTY))>1 S VALUE(BKTY,"NUM",BKNMTY)=1
  1.  .. ; Check for refusals of a screening
  1.  .. X BKREF
  1.  .. I '$D(BKMT) S VALUE(BKTY,"REF",BKNMTY)=0 Q
  1.  .. NEW LBIEN,PRNM,RETURN,RDT,REF,RFN,BKTT
  1.  .. S BKTT="",RETURN="",REF=0
  1.  .. F  S BKTT=$O(BKMT(BKTT)) Q:BKTT=""  D
  1.  ... S RDT="",QFL=0
  1.  ... F  S RDT=$O(BKMT(BKTT,RDT)) Q:RDT=""  D  Q:QFL
  1.  .... I RDT<BDATE Q
  1.  .... I RDT>EDATE Q
  1.  .... S RETURN=RETURN_$$FMTE^XLFDT(RDT,"2Z")
  1.  .... S RFN=""
  1.  .... F  S RFN=$O(BKMT(BKTT,RDT,RFN)) Q:RFN=""  D  Q:QFL
  1.  ..... S RTY=""
  1.  ..... F  S RTY=$O(BKMT(BKTT,RDT,RFN,RTY)) Q:RTY=""  D  Q:QFL
  1.  ...... S RIEN=$P(^AUPNPREF(RFN,0),U,6),QFL=1
  1.  ...... I $T(CPT^ICPTCOD)'="" S PRNM=$S(RTY="LAB":$P($G(^LAB(60,RIEN,.1)),U,1),RTY="CPT":$$ICPT^BKMUL3(RIEN,RDT,2),1:"") ; csv
  1.  ...... I $T(CPT^ICPTCOD)="" S PRNM=$S(RTY="LAB":$P($G(^LAB(60,RIEN,.1)),U,1),RTY="CPT":$P(^ICPT(RIEN,0),U,1),1:"")
  1.  ...... S RETURN=RETURN_" REF "_RTY_" "
  1.  ...... S RETURN=RETURN_"["_$S(PRNM'="":PRNM,1:$P(^AUPNPREF(RFN,0),U,5))_"]"_U_RFN
  1.  ...... S VALUE(BKTY,"REF",BKNMTY,BKDATE)=RETURN
  1.  .. ;S VALUE(BKTY,"REF",BKNMTY)=REF_U_RETURN
  1.  .. K BKMT
  1.  Q
  1.  ;
  1. SYP ;EP - Syphilis performance measures
  1.  D LABCODES^BKMCRS(BKMDFN,"BKM FTA-ABS TEST TAX","BKM FTA-ABS LOINC CODES","BKM FTA-ABS CPTS","",EDATE,BDATE,.IDATE,.LDATE,"",.PDATE,.PR,.NDATE,.NR,.LV)
  1.  I $G(LDATE)'="",(LDATE\1)<EDATE,(LDATE\1)>BDATE Q
  1.  D LABCODES^BKMCRS(BKMDFN,"BKM RPR TAX","BKM RPR LOINC CODES","BKM RPR CPTS","",EDATE,BDATE,.IDATE,.LDATE,"",.PDATE,.PR,.NDATE,.NR,.LV)
  1.  Q
  1.  ;
  1. SRF ;EP - Syphilis refusal
  1.  S GLOBAL="BKMT(""SYP"",VSTDT,TEST,""LAB"")"
  1.  D REFUSAL^BKMIXX2(BKMDFN,60,"BKM FTA-ABS TEST TAX","","",GLOBAL)
  1.  D REFUSAL^BKMIXX2(BKMDFN,60,"BKM RPR TAX","","",GLOBAL)
  1.  S GLOBAL="BKMT(""SYP"",VSTDT,TEST,""CPT"")"
  1.  D REFUSAL^BKMIXX2(BKMDFN,81,"BKM FTA-ABS CPTS","","",GLOBAL)
  1.  D REFUSAL^BKMIXX2(BKMDFN,81,"BKM RPR CPTS","","",GLOBAL)
  1.  Q
  1.  ;
  1. HIV ;EP - HIV performance measure
  1.  ; Check for any HIV/AIDS diagnosis prior to the STI diagnosis
  1.  ; This is a contraindication for HIV/AIDS screening
  1.  NEW HEDATE,HKDATE
  1.  S HEDATE=EDATE,HKDATE=""
  1.  ;S HVDFL=$$HIVS^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
  1.  ;I HVDFL D HIVE^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
  1.  D HIVE^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
  1.  I +$G(VALUE(BKTY,"NUM",BKNMTY,BKDATE))'=0 Q
  1.  ;
  1.  D LABCODES^BKMCRS(BKMDFN,"BGP HIV TEST TAX","BGP HIV TEST LOINC CODES","BGP CPT HIV TESTS","",EDATE,BDATE,.IDATE,.LDATE,.LR,.PDATE,.PR,.NDATE,.NR,.LV)
  1.  Q