BKMQQCR3.m

BKMQQCR3 ;PRXM/HC/BWF - BKMV Quality of Care Report; [ 1/19/2005  7:16 PM ]

 ;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40

 ; Quality of Care Audit Report

 Q

TETSTAT ; EP - Tetanus Status

 N TETDT,TETDT1,CVXTAX,ICDTAX,PRCTAX,CPTTAX,GLOBAL,GLOBAL2,REFGLOB,TOTPTS,BKMDFN

 S TETDT=$$FMADD^XLFDT(EDATE,-3650)

 S TETDT1=$$FMADD^XLFDT(EDATE,-365)

 S CVXTAX="BKM TETANUS IZ CVX CODES"

 S ICDTAX="BKM TETANUS IZ DXS"

 S PRCTAX="BKM TETANUS IZ PROCEDURES"

 S CPTTAX="BKM TETANUS IZ CPTS"

 S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""TET"",VSTDT,TEST)"

 S REFGLOB=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""TETREF"",VSTDT,TEST)"

 S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""TETPTCNT"")"

 S BKMDFN=0,@TOTPTS=0

 F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D

 .D ICDTAX^BKMIXX1(BKMDFN,ICDTAX,EDATE,TETDT,GLOBAL)

 .D CPTTAX^BKMIXX(BKMDFN,CPTTAX,EDATE,TETDT,GLOBAL)

 .D PRCTAX^BKMIXX1(BKMDFN,PRCTAX,EDATE,TETDT,GLOBAL)

 .D CVXTAX^BKMIXX1(BKMDFN,CVXTAX,EDATE,TETDT,GLOBAL)

 .; Refusals are only counted from last year.

 .D REFUSAL^BKMIXX2(BKMDFN,9999999.14,CVXTAX,EDATE,TETDT1,REFGLOB)

 .I $D(@GLOB@("HIVCHK",BKMDFN,"TET"))!$D(@GLOB@("HIVCHK",BKMDFN,"TETREF")) S @TOTPTS=@TOTPTS+1 Q

 Q

EYEEXAM ; EP - Eye Exam Status

 N EEXAMDT,CPTTAX,GLOBAL,REFGLOB,TOTPTS,BKMDFN,CLINIC,PROVIDER

 S EEXAMDT=$$FMADD^XLFDT(EDATE,-365)

 S CPTTAX="BGP DM EYE EXAM CPTS"

 S CPTTAX1="BGP RETINAL EXAM CPTS"

 S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""EYE"",VSTDT,TEST)"

 S REFGLOB=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""EYEREF"",VSTDT,TEST)"

 S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""EYEPTCNT"")"

 S BKMDFN=0,@TOTPTS=0

 F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D

 .D CPTTAX^BKMIXX(BKMDFN,CPTTAX,EDATE,EEXAMDT,GLOBAL)

 .D CPTTAX^BKMIXX(BKMDFN,CPTTAX1,EDATE,EEXAMDT,GLOBAL)

 .F CLINIC=17,18,64,"A2" D CLNTAX^BKMIXX2(BKMDFN,CLINIC,EDATE,EEXAMDT,GLOBAL)

 .F PROVIDER=79,24,"08" D PRVTAX^BKMIXX2(BKMDFN,PROVIDER,EDATE,EEXAMDT,GLOBAL)

 .D EXAMTAX^BKMIXX1(BKMDFN,"03",EDATE,EEXAMDT,GLOBAL)

 .;D PROCTAX^BKMIXX2(BKMDFN,95.02,EDATE,EEXAMDT,GLOBAL)

 .D PRCTAX^BKMIXX1(BKMDFN,"BQI EYE EXAM PROCS",EDATE,EEXAMDT,GLOBAL)

 .;D POVTAX^BKMIXX2(BKMDFN,"V72.0",EDATE,EEXAMDT,GLOBAL)

 .D ICDTAX^BKMIXX1(BKMDFN,"BQI EYE EXAM DXS",EDATE,EEXAMDT,GLOBAL)

 .I $D(@GLOB@("HIVCHK",BKMDFN,"EYE")) S @TOTPTS=@TOTPTS+1 Q

 .D REFUSAL^BKMIXX2(BKMDFN,9999999.15,"03",EDATE,EEXAMDT,REFGLOB)

 .I $D(@GLOB@("HIVCHK",BKMDFN,"EYEREF")) S @TOTPTS=@TOTPTS+1

 Q

DENTEXAM ; EP - Dental Exam Status

 N DEXAMDT,ICDTAX,ADATAX,GLOBAL,REFGLOB,TOTPTS,BKMDFN

 S DEXAMDT=$$FMADD^XLFDT(EDATE,-365)

 S ICDTAX="BKM DENTAL EXAMINATION"

 S ADATAX="BGP DENTAL EXAM DENTAL CODE"

 S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""DENT"",VSTDT,TEST)"

 S REFGLOB=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""DENTREF"",VSTDT,TEST)"

 S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""DENTPTCNT"")"

 S BKMDFN=0,@TOTPTS=0

 F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D

 .D ICDTAX^BKMIXX1(BKMDFN,ICDTAX,EDATE,DEXAMDT,GLOBAL)

 .D ADATAX^BKMIXX(BKMDFN,ADATAX,EDATE,DEXAMDT,GLOBAL)

 .D EXAMTAX^BKMIXX1(BKMDFN,"30",EDATE,DEXAMDT,GLOBAL)

 .I $D(@GLOB@("HIVCHK",BKMDFN,"DENT")) S @TOTPTS=@TOTPTS+1 Q

 .D REFUSAL^BKMIXX2(BKMDFN,9999999.15,"30",EDATE,DEXAMDT,REFGLOB)

 .I $D(@GLOB@("HIVCHK",BKMDFN,"DENTREF")) S @TOTPTS=@TOTPTS+1

 Q

PAP ; EP - Pap Smear Status

 N PAPDT,HISTDT,CPTTAX,ICDTAX,PRCTAX,LOINTAX,SITETAX,CPTTAX1,ICDTAX1

 N GLOBAL,GLOBAL1,REFGLOB,TOTPTS,SEX,AGE,BKMDFN,PRCTAX1

 S HISTDT=""

 S CPTTAX1="BGP HYSTERECTOMY CPTS"

 S PRCTAX1="BGP HYSTERECTOMY PROCEDURES"

 S ICDTAX1="BGP HYSTERECTOMY DXS"

 S GLOBAL1=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""HIST"",VSTDT,TEST)"

 S PAPDT=$$FMADD^XLFDT(EDATE,-365)

 S CPTTAX="BGP CPT PAP"

 S ICDTAX="BGP PAP SMEAR DXS"

 S PRCTAX="BQI PAP PROCEDURES"

 S LOINTAX="BGP PAP LOINC CODES"

 S SITETAX="BGP PAP SMEAR TAX"

 S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""PAP"",VSTDT,TEST)"

 S REFGLOB=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""PAPREF"",VSTDT,TEST)"

 S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""PAPPTCNT"")"

 S BKMDFN=0,@TOTPTS=0

 F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D

 .S SEX=$$GET1^DIQ(2,BKMDFN,.02,"I")

 .;Only interested in female patients

 .I SEX'="F" Q

 .S AGE=$$AGE^BKMIMRP1(BKMDFN)

 .;Only interested in patients between 19 and 64

 .I AGE<19!(AGE>64)!(AGE'?1.N) Q

 .;Only interested in patients with no hysterectomy

 .D ICDTAX^BKMIXX1(BKMDFN,ICDTAX1,EDATE,HISTDT,GLOBAL1)

 .D CPTTAX^BKMIXX(BKMDFN,CPTTAX1,EDATE,HISTDT,GLOBAL1)

 .;D POVTAX^BKMIXX2(BKMDFN,618.5,EDATE,HISTDT,GLOBAL1)

 .D PRCTAX^BKMIXX1(BKMDFN,PRCTAX1,EDATE,HISTDT,GLOBAL1)

 .I $D(@GLOB@("HIVCHK",BKMDFN,"HIST")) Q

 .D ICDTAX^BKMIXX1(BKMDFN,ICDTAX,EDATE,PAPDT,GLOBAL)

 .D CPTTAX^BKMIXX(BKMDFN,CPTTAX,EDATE,PAPDT,GLOBAL)

 .D PRCTAX^BKMIXX1(BKMDFN,PRCTAX,EDATE,PAPDT,GLOBAL)

 .D LABTAX^BKMIXX(BKMDFN,SITETAX,EDATE,PAPDT,GLOBAL)

 .D LOINC^BKMIXX(BKMDFN,LOINTAX,EDATE,PAPDT,GLOBAL)

 .D WHTAX^BKMIXX2(BKMDFN,"PAP SMEAR",EDATE,PAPDT,GLOBAL)

 .D REFUSAL^BKMIXX2(BKMDFN,60,LOINTAX,EDATE,PAPDT,REFGLOB)

 .D REFUSAL^BKMIXX2(BKMDFN,60,SITETAX,EDATE,PAPDT,REFGLOB)

 .I $D(@GLOB@("HIVCHK",BKMDFN,"PAP"))!$D(@GLOB@("HIVCHK",BKMDFN,"PAPREF")) S @TOTPTS=@TOTPTS+1

 Q

BKMQQCR3  ;PRXM/HC/BWF - BKMV Quality of Care Report; [ 1/19/2005  7:16 PM ]

 +1       ;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40

 +2       ; Quality of Care Audit Report

 +3        QUIT 

TETSTAT   ; EP - Tetanus Status

 +1        NEW TETDT,TETDT1,CVXTAX,ICDTAX,PRCTAX,CPTTAX,GLOBAL,GLOBAL2,REFGLOB,TOTPTS,BKMDFN

 +2        SET TETDT=$$FMADD^XLFDT(EDATE,-3650)

 +3        SET TETDT1=$$FMADD^XLFDT(EDATE,-365)

 +4        SET CVXTAX="BKM TETANUS IZ CVX CODES"

 +5        SET ICDTAX="BKM TETANUS IZ DXS"

 +6        SET PRCTAX="BKM TETANUS IZ PROCEDURES"

 +7        SET CPTTAX="BKM TETANUS IZ CPTS"

 +8        SET GLOBAL=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""TET"",VSTDT,TEST)"

 +9        SET REFGLOB=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""TETREF"",VSTDT,TEST)"

 +10       SET TOTPTS=$PIECE(GLOB,")")_",""HIVCHK"",""TETPTCNT"")"

 +11       SET BKMDFN=0

           SET @TOTPTS=0

 +12       FOR 

               SET BKMDFN=$ORDER(@GLOB@("HIVCHK",BKMDFN))

               IF 'BKMDFN

                   QUIT 

               Begin DoDot:1

 +13               DO ICDTAX^BKMIXX1(BKMDFN,ICDTAX,EDATE,TETDT,GLOBAL)

 +14               DO CPTTAX^BKMIXX(BKMDFN,CPTTAX,EDATE,TETDT,GLOBAL)

 +15               DO PRCTAX^BKMIXX1(BKMDFN,PRCTAX,EDATE,TETDT,GLOBAL)

 +16               DO CVXTAX^BKMIXX1(BKMDFN,CVXTAX,EDATE,TETDT,GLOBAL)

 +17      ; Refusals are only counted from last year.

 +18               DO REFUSAL^BKMIXX2(BKMDFN,9999999.14,CVXTAX,EDATE,TETDT1,REFGLOB)

 +19               IF $DATA(@GLOB@("HIVCHK",BKMDFN,"TET"))!$DATA(@GLOB@("HIVCHK",BKMDFN,"TETREF"))

                       SET @TOTPTS=@TOTPTS+1

                       QUIT 

               End DoDot:1

 +20       QUIT 

EYEEXAM   ; EP - Eye Exam Status

 +1        NEW EEXAMDT,CPTTAX,GLOBAL,REFGLOB,TOTPTS,BKMDFN,CLINIC,PROVIDER

 +2        SET EEXAMDT=$$FMADD^XLFDT(EDATE,-365)

 +3        SET CPTTAX="BGP DM EYE EXAM CPTS"

 +4        SET CPTTAX1="BGP RETINAL EXAM CPTS"

 +5        SET GLOBAL=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""EYE"",VSTDT,TEST)"

 +6        SET REFGLOB=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""EYEREF"",VSTDT,TEST)"

 +7        SET TOTPTS=$PIECE(GLOB,")")_",""HIVCHK"",""EYEPTCNT"")"

 +8        SET BKMDFN=0

           SET @TOTPTS=0

 +9        FOR 

               SET BKMDFN=$ORDER(@GLOB@("HIVCHK",BKMDFN))

               IF 'BKMDFN

                   QUIT 

               Begin DoDot:1

 +10               DO CPTTAX^BKMIXX(BKMDFN,CPTTAX,EDATE,EEXAMDT,GLOBAL)

 +11               DO CPTTAX^BKMIXX(BKMDFN,CPTTAX1,EDATE,EEXAMDT,GLOBAL)

 +12               FOR CLINIC=17,18,64,"A2"

                       DO CLNTAX^BKMIXX2(BKMDFN,CLINIC,EDATE,EEXAMDT,GLOBAL)

 +13               FOR PROVIDER=79,24,"08"

                       DO PRVTAX^BKMIXX2(BKMDFN,PROVIDER,EDATE,EEXAMDT,GLOBAL)

 +14               DO EXAMTAX^BKMIXX1(BKMDFN,"03",EDATE,EEXAMDT,GLOBAL)

 +15      ;D PROCTAX^BKMIXX2(BKMDFN,95.02,EDATE,EEXAMDT,GLOBAL)

 +16               DO PRCTAX^BKMIXX1(BKMDFN,"BQI EYE EXAM PROCS",EDATE,EEXAMDT,GLOBAL)

 +17      ;D POVTAX^BKMIXX2(BKMDFN,"V72.0",EDATE,EEXAMDT,GLOBAL)

 +18               DO ICDTAX^BKMIXX1(BKMDFN,"BQI EYE EXAM DXS",EDATE,EEXAMDT,GLOBAL)

 +19               IF $DATA(@GLOB@("HIVCHK",BKMDFN,"EYE"))

                       SET @TOTPTS=@TOTPTS+1

                       QUIT 

 +20               DO REFUSAL^BKMIXX2(BKMDFN,9999999.15,"03",EDATE,EEXAMDT,REFGLOB)

 +21               IF $DATA(@GLOB@("HIVCHK",BKMDFN,"EYEREF"))

                       SET @TOTPTS=@TOTPTS+1

               End DoDot:1

 +22       QUIT 

DENTEXAM  ; EP - Dental Exam Status

 +1        NEW DEXAMDT,ICDTAX,ADATAX,GLOBAL,REFGLOB,TOTPTS,BKMDFN

 +2        SET DEXAMDT=$$FMADD^XLFDT(EDATE,-365)

 +3        SET ICDTAX="BKM DENTAL EXAMINATION"

 +4        SET ADATAX="BGP DENTAL EXAM DENTAL CODE"

 +5        SET GLOBAL=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""DENT"",VSTDT,TEST)"

 +6        SET REFGLOB=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""DENTREF"",VSTDT,TEST)"

 +7        SET TOTPTS=$PIECE(GLOB,")")_",""HIVCHK"",""DENTPTCNT"")"

 +8        SET BKMDFN=0

           SET @TOTPTS=0

 +9        FOR 

               SET BKMDFN=$ORDER(@GLOB@("HIVCHK",BKMDFN))

               IF 'BKMDFN

                   QUIT 

               Begin DoDot:1

 +10               DO ICDTAX^BKMIXX1(BKMDFN,ICDTAX,EDATE,DEXAMDT,GLOBAL)

 +11               DO ADATAX^BKMIXX(BKMDFN,ADATAX,EDATE,DEXAMDT,GLOBAL)

 +12               DO EXAMTAX^BKMIXX1(BKMDFN,"30",EDATE,DEXAMDT,GLOBAL)

 +13               IF $DATA(@GLOB@("HIVCHK",BKMDFN,"DENT"))

                       SET @TOTPTS=@TOTPTS+1

                       QUIT 

 +14               DO REFUSAL^BKMIXX2(BKMDFN,9999999.15,"30",EDATE,DEXAMDT,REFGLOB)

 +15               IF $DATA(@GLOB@("HIVCHK",BKMDFN,"DENTREF"))

                       SET @TOTPTS=@TOTPTS+1

               End DoDot:1

 +16       QUIT 

PAP       ; EP - Pap Smear Status

 +1        NEW PAPDT,HISTDT,CPTTAX,ICDTAX,PRCTAX,LOINTAX,SITETAX,CPTTAX1,ICDTAX1

 +2        NEW GLOBAL,GLOBAL1,REFGLOB,TOTPTS,SEX,AGE,BKMDFN,PRCTAX1

 +3        SET HISTDT=""

 +4        SET CPTTAX1="BGP HYSTERECTOMY CPTS"

 +5        SET PRCTAX1="BGP HYSTERECTOMY PROCEDURES"

 +6        SET ICDTAX1="BGP HYSTERECTOMY DXS"

 +7        SET GLOBAL1=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""HIST"",VSTDT,TEST)"

 +8        SET PAPDT=$$FMADD^XLFDT(EDATE,-365)

 +9        SET CPTTAX="BGP CPT PAP"

 +10       SET ICDTAX="BGP PAP SMEAR DXS"

 +11       SET PRCTAX="BQI PAP PROCEDURES"

 +12       SET LOINTAX="BGP PAP LOINC CODES"

 +13       SET SITETAX="BGP PAP SMEAR TAX"

 +14       SET GLOBAL=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""PAP"",VSTDT,TEST)"

 +15       SET REFGLOB=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""PAPREF"",VSTDT,TEST)"

 +16       SET TOTPTS=$PIECE(GLOB,")")_",""HIVCHK"",""PAPPTCNT"")"

 +17       SET BKMDFN=0

           SET @TOTPTS=0

 +18       FOR 

               SET BKMDFN=$ORDER(@GLOB@("HIVCHK",BKMDFN))

               IF 'BKMDFN

                   QUIT 

               Begin DoDot:1

 +19               SET SEX=$$GET1^DIQ(2,BKMDFN,.02,"I")

 +20      ;Only interested in female patients

 +21               IF SEX'="F"

                       QUIT 

 +22               SET AGE=$$AGE^BKMIMRP1(BKMDFN)

 +23      ;Only interested in patients between 19 and 64

 +24               IF AGE<19!(AGE>64)!(AGE'?1.N)

                       QUIT 

 +25      ;Only interested in patients with no hysterectomy

 +26               DO ICDTAX^BKMIXX1(BKMDFN,ICDTAX1,EDATE,HISTDT,GLOBAL1)

 +27               DO CPTTAX^BKMIXX(BKMDFN,CPTTAX1,EDATE,HISTDT,GLOBAL1)

 +28      ;D POVTAX^BKMIXX2(BKMDFN,618.5,EDATE,HISTDT,GLOBAL1)

 +29               DO PRCTAX^BKMIXX1(BKMDFN,PRCTAX1,EDATE,HISTDT,GLOBAL1)

 +30               IF $DATA(@GLOB@("HIVCHK",BKMDFN,"HIST"))

                       QUIT 

 +31               DO ICDTAX^BKMIXX1(BKMDFN,ICDTAX,EDATE,PAPDT,GLOBAL)

 +32               DO CPTTAX^BKMIXX(BKMDFN,CPTTAX,EDATE,PAPDT,GLOBAL)

 +33               DO PRCTAX^BKMIXX1(BKMDFN,PRCTAX,EDATE,PAPDT,GLOBAL)

 +34               DO LABTAX^BKMIXX(BKMDFN,SITETAX,EDATE,PAPDT,GLOBAL)

 +35               DO LOINC^BKMIXX(BKMDFN,LOINTAX,EDATE,PAPDT,GLOBAL)

 +36               DO WHTAX^BKMIXX2(BKMDFN,"PAP SMEAR",EDATE,PAPDT,GLOBAL)

 +37               DO REFUSAL^BKMIXX2(BKMDFN,60,LOINTAX,EDATE,PAPDT,REFGLOB)

 +38               DO REFUSAL^BKMIXX2(BKMDFN,60,SITETAX,EDATE,PAPDT,REFGLOB)

 +39               IF $DATA(@GLOB@("HIVCHK",BKMDFN,"PAP"))!$DATA(@GLOB@("HIVCHK",BKMDFN,"PAPREF"))

                       SET @TOTPTS=@TOTPTS+1

               End DoDot:1

 +40       QUIT