BKMSTI ;PRXM/HC/ALA - Sexually Transmitted Infection Screening ; 12 Mar 2007 1:52 PM
;;2.1;HIV MANAGEMENT SYSTEM;**1,2**;Feb 07, 2011;Build 11
;
;
EN(BKMDFN,BKBDT,BKEDT,TYPE,VALUE,HVDFL) ;EP
;
; Input
; BKMDFN - Patient internal entry number
; BRDT - CRS Report Period begin date
; ERDT - CRS Report Period end date (not used at this time because of the 300
; day limitation see BKEDT below)
; TYPE - Type of STI (can be an individual one such as CHLAMYDIA, etc.;
; those 'KEY' STIs or 'OTHER' STIs as defined in the HMS STI SCREENING
; File #90454)
; VALUE - The name of the array to return the data in
; HVDFL - The HIV Diagnosis contraindication flag
;
; Output
; VALUE - structure is
; STI is the sexual transmitted infection code
; "DEN" is denominator data
; "NUM" is numerator data
; "REF" is refusal data
; SCSTI is the screening STI code
; # of incidences found within a 2-month period
; 0 is no incidences found
; otherwise is number found within date range
; (STI,"DEN")=#^date diagnosis;
; STI,"NUM",SCSTI)=#^screening information
; STI,"REF",SCSTI)=#^refusal information
;
NEW BKMIEN,BKDEN,ARRAY,BKTY,IEN,STIEN,BKPER,BKREF,BKNMTY,BKDATE
NEW BKMEDT,GLOBAL,IDATE,PDATE,IDXDT,LDATE,LIEN,LV,NDATE,NR,NXDT,PDATE,OFLG
NEW OR,PR,ODATE,VISIT,VSDT,QFL,RIEN,RTY
;
; Set beginning date to 2 months (60 days) prior to CRS report period begin date
; through the first 300 days of the CRS report period
K ARRAY,ZARRAY
;
; Check if passed a specific STI
S BKMIEN=$$FIND1^DIC(90454,,"MX",TYPE)
I BKMIEN D
. S BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
. ; Get the denominator executable
. S BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
. ;
. X BKDEN
. ; if no data, then the denominator should be zero
. I '$D(ARRAY) S VALUE(BKTY,"DEN")=0 Q
. ; find any numerator or refusal information
. D FND
;
; Only pull the key information
I TYPE="KEY" D
. S BKMIEN=""
. F S BKMIEN=$O(^BKM(90454,"C","K",BKMIEN)) Q:BKMIEN="" D
.. S BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
.. S BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
.. ; Denominator code
.. X BKDEN
.. ; if no data, then the denominator should be zero
.. I '$D(ARRAY) S VALUE(BKTY,"DEN")=0 Q
.. ; find any numerator or refusal information
.. D FND
;
; Only pull the other STIs
I TYPE="OTHER" D
. S BKMIEN=""
. F S BKMIEN=$O(^BKM(90454,"C","O",BKMIEN)) Q:BKMIEN="" D
.. S BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
.. S BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
.. ; Denominator code
.. X BKDEN
.. ; if no data, then the denominator should be zero
.. I '$D(ARRAY) S VALUE(BKTY,"DEN")=0 Q
.. ; find any numerator or refusal information
.. D FND
;
; Pull all STIs
I TYPE="" D
. S BKMIEN=0
. F S BKMIEN=$O(^BKM(90454,BKMIEN)) Q:'BKMIEN D
.. S BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
.. S BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
.. ; Denominator code
.. X BKDEN
.. ; if no data, then the denominator should be zero
.. I '$D(ARRAY) S VALUE(BKTY,"DEN")=0 Q
.. ; find any numerator or refusal information
.. D FND
Q
;
FND ; Find numerator data for all associated screenings
; Parameters
; BKPER - Performance executable
; BKREF - Refusal executable
;
S IEN=0
F S IEN=$O(^BKM(90454,BKMIEN,10,IEN)) Q:'IEN D
. S STIEN=$P(^BKM(90454,BKMIEN,10,IEN,0),U,1)
. S BKPER=$$GET1^DIQ(90454,STIEN_",",2,"E")
. S BKREF=$$GET1^DIQ(90454,STIEN_",",3,"E")
. S BKNMTY=$$GET1^DIQ(90454,STIEN_",",.03,"E")
. ; For each denominator date
. S BKDATE=""
. F S BKDATE=$O(ARRAY(BKTY,BKDATE)) Q:BKDATE="" D
.. NEW EDATE,BDATE
.. ; Check for performance of a screen 30 days prior and 2 months after
.. ; the denominator date
.. ;S EDATE=$$FMADD^XLFDT(BKDATE,60),BDATE=$$FMADD^XLFDT(BKDATE,-30)
.. S EDATE=$$FMADD^XLFDT(BKDATE,(30.4167*2)),BDATE=$$FMADD^XLFDT(BKDATE,-30.4167)
.. X BKPER
.. I '$D(VALUE(BKTY,"NUM",BKNMTY)) S VALUE(BKTY,"NUM",BKNMTY)=0
.. I $D(VALUE(BKTY,"NUM",BKNMTY))>1 S VALUE(BKTY,"NUM",BKNMTY)=1
.. ; Check for refusals of a screening
.. X BKREF
.. I '$D(BKMT) S VALUE(BKTY,"REF",BKNMTY)=0 Q
.. NEW LBIEN,PRNM,RETURN,RDT,REF,RFN,BKTT
.. S BKTT="",RETURN="",REF=0
.. F S BKTT=$O(BKMT(BKTT)) Q:BKTT="" D
... S RDT="",QFL=0
... F S RDT=$O(BKMT(BKTT,RDT)) Q:RDT="" D Q:QFL
.... I RDT<BDATE Q
.... I RDT>EDATE Q
.... S RETURN=RETURN_$$FMTE^XLFDT(RDT,"2Z")
.... S RFN=""
.... F S RFN=$O(BKMT(BKTT,RDT,RFN)) Q:RFN="" D Q:QFL
..... S RTY=""
..... F S RTY=$O(BKMT(BKTT,RDT,RFN,RTY)) Q:RTY="" D Q:QFL
...... S RIEN=$P(^AUPNPREF(RFN,0),U,6),QFL=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
...... 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:"")
...... S RETURN=RETURN_" REF "_RTY_" "
...... S RETURN=RETURN_"["_$S(PRNM'="":PRNM,1:$P(^AUPNPREF(RFN,0),U,5))_"]"_U_RFN
...... S VALUE(BKTY,"REF",BKNMTY,BKDATE)=RETURN
.. ;S VALUE(BKTY,"REF",BKNMTY)=REF_U_RETURN
.. K BKMT
Q
;
SYP ;EP - Syphilis performance measures
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)
I $G(LDATE)'="",(LDATE\1)<EDATE,(LDATE\1)>BDATE Q
D LABCODES^BKMCRS(BKMDFN,"BKM RPR TAX","BKM RPR LOINC CODES","BKM RPR CPTS","",EDATE,BDATE,.IDATE,.LDATE,"",.PDATE,.PR,.NDATE,.NR,.LV)
Q
;
SRF ;EP - Syphilis refusal
S GLOBAL="BKMT(""SYP"",VSTDT,TEST,""LAB"")"
D REFUSAL^BKMIXX2(BKMDFN,60,"BKM FTA-ABS TEST TAX","","",GLOBAL)
D REFUSAL^BKMIXX2(BKMDFN,60,"BKM RPR TAX","","",GLOBAL)
S GLOBAL="BKMT(""SYP"",VSTDT,TEST,""CPT"")"
D REFUSAL^BKMIXX2(BKMDFN,81,"BKM FTA-ABS CPTS","","",GLOBAL)
D REFUSAL^BKMIXX2(BKMDFN,81,"BKM RPR CPTS","","",GLOBAL)
Q
;
HIV ;EP - HIV performance measure
; Check for any HIV/AIDS diagnosis prior to the STI diagnosis
; This is a contraindication for HIV/AIDS screening
NEW HEDATE,HKDATE
S HEDATE=EDATE,HKDATE=""
;S HVDFL=$$HIVS^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
;I HVDFL D HIVE^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
D HIVE^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
I +$G(VALUE(BKTY,"NUM",BKNMTY,BKDATE))'=0 Q
;
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)
Q
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
+2 ;
+3 ;
EN(BKMDFN,BKBDT,BKEDT,TYPE,VALUE,HVDFL) ;EP
+1 ;
+2 ; Input
+3 ; BKMDFN - Patient internal entry number
+4 ; BRDT - CRS Report Period begin date
+5 ; ERDT - CRS Report Period end date (not used at this time because of the 300
+6 ; day limitation see BKEDT below)
+7 ; TYPE - Type of STI (can be an individual one such as CHLAMYDIA, etc.;
+8 ; those 'KEY' STIs or 'OTHER' STIs as defined in the HMS STI SCREENING
+9 ; File #90454)
+10 ; VALUE - The name of the array to return the data in
+11 ; HVDFL - The HIV Diagnosis contraindication flag
+12 ;
+13 ; Output
+14 ; VALUE - structure is
+15 ; STI is the sexual transmitted infection code
+16 ; "DEN" is denominator data
+17 ; "NUM" is numerator data
+18 ; "REF" is refusal data
+19 ; SCSTI is the screening STI code
+20 ; # of incidences found within a 2-month period
+21 ; 0 is no incidences found
+22 ; otherwise is number found within date range
+23 ; (STI,"DEN")=#^date diagnosis;
+24 ; STI,"NUM",SCSTI)=#^screening information
+25 ; STI,"REF",SCSTI)=#^refusal information
+26 ;
+27 NEW BKMIEN,BKDEN,ARRAY,BKTY,IEN,STIEN,BKPER,BKREF,BKNMTY,BKDATE
+28 NEW BKMEDT,GLOBAL,IDATE,PDATE,IDXDT,LDATE,LIEN,LV,NDATE,NR,NXDT,PDATE,OFLG
+29 NEW OR,PR,ODATE,VISIT,VSDT,QFL,RIEN,RTY
+30 ;
+31 ; Set beginning date to 2 months (60 days) prior to CRS report period begin date
+32 ; through the first 300 days of the CRS report period
+33 KILL ARRAY,ZARRAY
+34 ;
+35 ; Check if passed a specific STI
+36 SET BKMIEN=$$FIND1^DIC(90454,,"MX",TYPE)
+37 IF BKMIEN
Begin DoDot:1
+38 SET BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
+39 ; Get the denominator executable
+40 SET BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
+41 ;
+42 XECUTE BKDEN
+43 ; if no data, then the denominator should be zero
+44 IF '$DATA(ARRAY)
SET VALUE(BKTY,"DEN")=0
QUIT
+45 ; find any numerator or refusal information
+46 DO FND
End DoDot:1
+47 ;
+48 ; Only pull the key information
+49 IF TYPE="KEY"
Begin DoDot:1
+50 SET BKMIEN=""
+51 FOR
SET BKMIEN=$ORDER(^BKM(90454,"C","K",BKMIEN))
IF BKMIEN=""
QUIT
Begin DoDot:2
+52 SET BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
+53 SET BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
+54 ; Denominator code
+55 XECUTE BKDEN
+56 ; if no data, then the denominator should be zero
+57 IF '$DATA(ARRAY)
SET VALUE(BKTY,"DEN")=0
QUIT
+58 ; find any numerator or refusal information
+59 DO FND
End DoDot:2
End DoDot:1
+60 ;
+61 ; Only pull the other STIs
+62 IF TYPE="OTHER"
Begin DoDot:1
+63 SET BKMIEN=""
+64 FOR
SET BKMIEN=$ORDER(^BKM(90454,"C","O",BKMIEN))
IF BKMIEN=""
QUIT
Begin DoDot:2
+65 SET BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
+66 SET BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
+67 ; Denominator code
+68 XECUTE BKDEN
+69 ; if no data, then the denominator should be zero
+70 IF '$DATA(ARRAY)
SET VALUE(BKTY,"DEN")=0
QUIT
+71 ; find any numerator or refusal information
+72 DO FND
End DoDot:2
End DoDot:1
+73 ;
+74 ; Pull all STIs
+75 IF TYPE=""
Begin DoDot:1
+76 SET BKMIEN=0
+77 FOR
SET BKMIEN=$ORDER(^BKM(90454,BKMIEN))
IF 'BKMIEN
QUIT
Begin DoDot:2
+78 SET BKTY=$$GET1^DIQ(90454,BKMIEN_",",.03,"E")
+79 SET BKDEN=$$GET1^DIQ(90454,BKMIEN_",",1,"E")
+80 ; Denominator code
+81 XECUTE BKDEN
+82 ; if no data, then the denominator should be zero
+83 IF '$DATA(ARRAY)
SET VALUE(BKTY,"DEN")=0
QUIT
+84 ; find any numerator or refusal information
+85 DO FND
End DoDot:2
End DoDot:1
+86 QUIT
+87 ;
FND ; Find numerator data for all associated screenings
+1 ; Parameters
+2 ; BKPER - Performance executable
+3 ; BKREF - Refusal executable
+4 ;
+5 SET IEN=0
+6 FOR
SET IEN=$ORDER(^BKM(90454,BKMIEN,10,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+7 SET STIEN=$PIECE(^BKM(90454,BKMIEN,10,IEN,0),U,1)
+8 SET BKPER=$$GET1^DIQ(90454,STIEN_",",2,"E")
+9 SET BKREF=$$GET1^DIQ(90454,STIEN_",",3,"E")
+10 SET BKNMTY=$$GET1^DIQ(90454,STIEN_",",.03,"E")
+11 ; For each denominator date
+12 SET BKDATE=""
+13 FOR
SET BKDATE=$ORDER(ARRAY(BKTY,BKDATE))
IF BKDATE=""
QUIT
Begin DoDot:2
+14 NEW EDATE,BDATE
+15 ; Check for performance of a screen 30 days prior and 2 months after
+16 ; the denominator date
+17 ;S EDATE=$$FMADD^XLFDT(BKDATE,60),BDATE=$$FMADD^XLFDT(BKDATE,-30)
+18 SET EDATE=$$FMADD^XLFDT(BKDATE,(30.4167*2))
SET BDATE=$$FMADD^XLFDT(BKDATE,-30.4167)
+19 XECUTE BKPER
+20 IF '$DATA(VALUE(BKTY,"NUM",BKNMTY))
SET VALUE(BKTY,"NUM",BKNMTY)=0
+21 IF $DATA(VALUE(BKTY,"NUM",BKNMTY))>1
SET VALUE(BKTY,"NUM",BKNMTY)=1
+22 ; Check for refusals of a screening
+23 XECUTE BKREF
+24 IF '$DATA(BKMT)
SET VALUE(BKTY,"REF",BKNMTY)=0
QUIT
+25 NEW LBIEN,PRNM,RETURN,RDT,REF,RFN,BKTT
+26 SET BKTT=""
SET RETURN=""
SET REF=0
+27 FOR
SET BKTT=$ORDER(BKMT(BKTT))
IF BKTT=""
QUIT
Begin DoDot:3
+28 SET RDT=""
SET QFL=0
+29 FOR
SET RDT=$ORDER(BKMT(BKTT,RDT))
IF RDT=""
QUIT
Begin DoDot:4
+30 IF RDT<BDATE
QUIT
+31 IF RDT>EDATE
QUIT
+32 SET RETURN=RETURN_$$FMTE^XLFDT(RDT,"2Z")
+33 SET RFN=""
+34 FOR
SET RFN=$ORDER(BKMT(BKTT,RDT,RFN))
IF RFN=""
QUIT
Begin DoDot:5
+35 SET RTY=""
+36 FOR
SET RTY=$ORDER(BKMT(BKTT,RDT,RFN,RTY))
IF RTY=""
QUIT
Begin DoDot:6
+37 SET RIEN=$PIECE(^AUPNPREF(RFN,0),U,6)
SET QFL=1
+38 ; csv
IF $TEXT(CPT^ICPTCOD)'=""
SET PRNM=$SELECT(RTY="LAB":$PIECE($GET(^LAB(60,RIEN,.1)),U,1),RTY="CPT":$$ICPT^BKMUL3(RIEN,RDT,2),1:"")
+39 IF $TEXT(CPT^ICPTCOD)=""
SET PRNM=$SELECT(RTY="LAB":$PIECE($GET(^LAB(60,RIEN,.1)),U,1),RTY="CPT":$PIECE(^ICPT(RIEN,0),U,1),1:"")
+40 SET RETURN=RETURN_" REF "_RTY_" "
+41 SET RETURN=RETURN_"["_$SELECT(PRNM'="":PRNM,1:$PIECE(^AUPNPREF(RFN,0),U,5))_"]"_U_RFN
+42 SET VALUE(BKTY,"REF",BKNMTY,BKDATE)=RETURN
End DoDot:6
IF QFL
QUIT
End DoDot:5
IF QFL
QUIT
End DoDot:4
IF QFL
QUIT
End DoDot:3
+43 ;S VALUE(BKTY,"REF",BKNMTY)=REF_U_RETURN
+44 KILL BKMT
End DoDot:2
End DoDot:1
+45 QUIT
+46 ;
SYP ;EP - Syphilis performance measures
+1 DO 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)
+2 IF $GET(LDATE)'=""
IF (LDATE\1)<EDATE
IF (LDATE\1)>BDATE
QUIT
+3 DO LABCODES^BKMCRS(BKMDFN,"BKM RPR TAX","BKM RPR LOINC CODES","BKM RPR CPTS","",EDATE,BDATE,.IDATE,.LDATE,"",.PDATE,.PR,.NDATE,.NR,.LV)
+4 QUIT
+5 ;
SRF ;EP - Syphilis refusal
+1 SET GLOBAL="BKMT(""SYP"",VSTDT,TEST,""LAB"")"
+2 DO REFUSAL^BKMIXX2(BKMDFN,60,"BKM FTA-ABS TEST TAX","","",GLOBAL)
+3 DO REFUSAL^BKMIXX2(BKMDFN,60,"BKM RPR TAX","","",GLOBAL)
+4 SET GLOBAL="BKMT(""SYP"",VSTDT,TEST,""CPT"")"
+5 DO REFUSAL^BKMIXX2(BKMDFN,81,"BKM FTA-ABS CPTS","","",GLOBAL)
+6 DO REFUSAL^BKMIXX2(BKMDFN,81,"BKM RPR CPTS","","",GLOBAL)
+7 QUIT
+8 ;
HIV ;EP - HIV performance measure
+1 ; Check for any HIV/AIDS diagnosis prior to the STI diagnosis
+2 ; This is a contraindication for HIV/AIDS screening
+3 NEW HEDATE,HKDATE
+4 SET HEDATE=EDATE
SET HKDATE=""
+5 ;S HVDFL=$$HIVS^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
+6 ;I HVDFL D HIVE^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
+7 DO HIVE^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
+8 IF +$GET(VALUE(BKTY,"NUM",BKNMTY,BKDATE))'=0
QUIT
+9 ;
+10 DO 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)
+11 QUIT
