Routine: BKMQQCR5

BKMQQCR5 ;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

TOBACCO ; EP - Tobacco Use

 N TOBDT,ICDTAX,ADATAX,HFTAX,HFTAX1,HFTAX2,PTEDTAX,BKMSVTX

 N CLINIC,GL,GL2,GLOBAL,GLOBAL1,GLOBAL2,GLOBAL3,TOTPTS,BKMDFN,TOB

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

 ;DX.12 Tobacco Users

 S CPTTAX="BGP TOBACCO USER CPTS"

 S ICDTAX="BGP SMOKER ONLY DXS"

 S HFTAX1="BGP TOBACCO USER HLTH FACTORS"

 ;S.4 Tobacco Use Screen

 S CPTTAX1="BGP SMOKING CPTS"

 S ICDTAX1="BGP GPRA SMOKING DXS"

 S HFTAX="BGP TOBACCO SCREEN HLTH FACTOR"

 S ADATAX="BGP TOBACCO CESS DENTAL CODE"

 S PTEDTAX="TO-,-TO,-SHS" ; Tobacco

 S CLINIC=94

 ;ED.5 Tobacco Cessation Counseling (includes ADATAX, PTEDTAX, and CLINIC above)

 S CPTTAX2="BGP TOBACCO CESS CPTS"

 ;DX.7 Non Tobacco Users

 S HFTAX2="BQI NON TOBACCO USER FACTORS"

 S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""TOB"",VSTDT,TEST)" ; S.4 Tobacco Use Screen

 S GL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""TOB"")"

 S GLOBAL1=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""TOBUSER"",VSTDT,TEST)" ; DX.12 Tobacco Users

 S GLOBAL2=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""TOBED"",VSTDT,TEST)" ; ED.5 Tobacco Cessation Counseling

 S GL2=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""TOBED"")"

 S GLOBAL3=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""TOBNONUSER"",VSTDT,TEST)" ; DX.7 Non Tobacco Users

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

 S @TOTPTS=0,BKMDFN=0

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

 .;S.4 and DX.12 and ED.5

 .D ICDTAX^BKMIXX1(BKMDFN,ICDTAX1,EDATE,TOBDT,GLOBAL)

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

 .N CPT,EDT,TDT,GBL

 .S CPT=CPTTAX1_$C(29)_CPTTAX_$C(29)_CPTTAX2

 .S EDT=EDATE_$C(29)_EDATE_$C(29)_EDATE

 .;S TDT=TDT_$C(29)_TDT_$C(29)_TDT

 .S TDT=TOBDT_$C(29)_TOBDT_$C(29)_TOBDT

 .S GBL=GLOBAL_$C(29)_GLOBAL1_$C(29)_GLOBAL2

 .D CPTTAX^BKMIXX(BKMDFN,CPT,EDT,TDT,GBL)

 .K CPT,EDT,TDT,GBL

 .D ICDTAX^BKMIXX1(BKMDFN,ICDTAX,EDATE,TOBDT,GLOBAL1)

 .;D CPTTAX^BKMIXX(BKMDFN,CPTTAX,EDATE,TOBDT,GLOBAL1)

 .;ED.5

 .;D CPTTAX^BKMIXX(BKMDFN,CPTTAX2,EDATE,TOBDT,GLOBAL2)

 .; DX.12 only. Include problem list.

 .D PRBTAX^BKMIXX(BKMDFN,ICDTAX,EDATE,TOBDT,GLOBAL1)

 .;S.4 and ED.5

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

 .;D ADATAX^BKMIXX(BKMDFN,ADATAX,EDATE,TOBDT,GLOBAL2)

 .M @GL2=@GL

 .;S.4 and ED.5

 .D PTEDTAX^BKMIXX(BKMDFN,PTEDTAX,EDATE,TOBDT,GLOBAL,"","","",.BKMSVTX)

 .;D PTEDTAX^BKMIXX(BKMDFN,PTEDTAX,EDATE,TOBDT,GLOBAL2)

 .M @GL2=@GL

 .;S.4 and ED.5

 .D CLNTAX^BKMIXX2(BKMDFN,CLINIC,EDATE,TOBDT,GLOBAL)

 .D CLNTAX^BKMIXX2(BKMDFN,CLINIC,EDATE,TOBDT,GLOBAL2)

 .;S.4

 .D HFTAX^BKMIXX(BKMDFN,HFTAX,EDATE,TOBDT,GLOBAL)

 .;DX.12

 .D HFTAX^BKMIXX(BKMDFN,HFTAX1,EDATE,TOBDT,GLOBAL1)

 .;DX.7

 .D HFTAX^BKMIXX(BKMDFN,HFTAX2,EDATE,TOBDT,GLOBAL3)

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

SUBS01 ; EP - Substance Abuse

 N SUBS01DT,ICDTAX,ICDTAX2,ICDTAX3,HFTAX,PTEDTAX,GLOBAL,GLOBAL1,TOTPTS,BKMDFN,BKMSVTX

 N CD,BHP,BHPRB,MSR

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

 ;S.1

 S CPTTAX="BGP ALCOHOL SCREENING CPTS"

 S ICDTAX="BQI ALCOHOL SCREEN DXS"

 S ICDTAX2="BGP ALCOHOL DXS"

 S PRCTAX="BQI ALCOHOL PROCEDURES"

 S HFTAX="BGP ALCOHOL HLTH FACTOR"

 S PTEDTAX="CD-,-CD,AOD-,-AOD"

 ;S.3

 S ICDTAX3="BKM OTHER SUBSTANCE ABUSE DXS"

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

 ; IHS does not want Substance Abuse sub-totals originally requested

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

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

 S BKMDFN=0,@TOTPTS=0

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

 .;S.1

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

 .D ICDTAX^BKMIXX1(BKMDFN,ICDTAX2,EDATE,SUBS01DT,GLOBAL)

 .; D ICDTAX^BKMIXX1(BKMDFN,ICDTAX2,EDATE,SUBS01DT,GLOBAL1)

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

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

 .D HFTAX^BKMIXX(BKMDFN,HFTAX,EDATE,SUBS01DT,GLOBAL)

 .D PTEDTAX^BKMIXX(BKMDFN,PTEDTAX,EDATE,SUBS01DT,GLOBAL,"","","",.BKMSVTX)

 .D EXAMTAX^BKMIXX1(BKMDFN,"35",EDATE,SUBS01DT,GLOBAL)

 .F CD=10,27,29 S BHP(CD)=""

 .D BHPTAX^BKMIXX2(BKMDFN,.BHP,EDATE,SUBS01DT,GLOBAL)

 .F CD=29.1 S BHPRB(CD)=""

 .D BHPRBTAX^BKMIXX2(BKMDFN,.BHPRB,EDATE,SUBS01DT,GLOBAL)

 .F CD="AUDT","AUDC","CRFT" S MSR(CD)=""

 .D MSRTAX^BKMIXX2(BKMDFN,.MSR,EDATE,SUBS01DT,GLOBAL)

 .;S.3

 .;D ICDTAX^BKMIXX1(BKMDFN,ICDTAX3,EDATE,SUBS01DT,GLOBAL1)

 .D ICDTAX^BKMIXX1(BKMDFN,ICDTAX3,EDATE,SUBS01DT,GLOBAL)

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

BKMQQCR5  ;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

TOBACCO   ; EP - Tobacco Use

 +1        NEW TOBDT,ICDTAX,ADATAX,HFTAX,HFTAX1,HFTAX2,PTEDTAX,BKMSVTX

 +2        NEW CLINIC,GL,GL2,GLOBAL,GLOBAL1,GLOBAL2,GLOBAL3,TOTPTS,BKMDFN,TOB

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

 +4       ;DX.12 Tobacco Users

 +5        SET CPTTAX="BGP TOBACCO USER CPTS"

 +6        SET ICDTAX="BGP SMOKER ONLY DXS"

 +7        SET HFTAX1="BGP TOBACCO USER HLTH FACTORS"

 +8       ;S.4 Tobacco Use Screen

 +9        SET CPTTAX1="BGP SMOKING CPTS"

 +10       SET ICDTAX1="BGP GPRA SMOKING DXS"

 +11       SET HFTAX="BGP TOBACCO SCREEN HLTH FACTOR"

 +12       SET ADATAX="BGP TOBACCO CESS DENTAL CODE"

 +13      ; Tobacco

           SET PTEDTAX="TO-,-TO,-SHS"

 +14       SET CLINIC=94

 +15      ;ED.5 Tobacco Cessation Counseling (includes ADATAX, PTEDTAX, and CLINIC above)

 +16       SET CPTTAX2="BGP TOBACCO CESS CPTS"

 +17      ;DX.7 Non Tobacco Users

 +18       SET HFTAX2="BQI NON TOBACCO USER FACTORS"

 +19      ; S.4 Tobacco Use Screen

           SET GLOBAL=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""TOB"",VSTDT,TEST)"

 +20       SET GL=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""TOB"")"

 +21      ; DX.12 Tobacco Users

           SET GLOBAL1=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""TOBUSER"",VSTDT,TEST)"

 +22      ; ED.5 Tobacco Cessation Counseling

           SET GLOBAL2=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""TOBED"",VSTDT,TEST)"

 +23       SET GL2=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""TOBED"")"

 +24      ; DX.7 Non Tobacco Users

           SET GLOBAL3=$PIECE(GLOB,")")_",""HIVCHK"",BKMDFN,""TOBNONUSER"",VSTDT,TEST)"

 +25       SET TOTPTS=$PIECE(GLOB,")")_",""HIVCHK"",""TOBTOT"")"

 +26       SET @TOTPTS=0

           SET BKMDFN=0

 +27       FOR

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

               IF 'BKMDFN

                   QUIT

               Begin DoDot:1

 +28      ;S.4 and DX.12 and ED.5

 +29               DO ICDTAX^BKMIXX1(BKMDFN,ICDTAX1,EDATE,TOBDT,GLOBAL)

 +30      ;D CPTTAX^BKMIXX(BKMDFN,CPTTAX1,EDATE,TOBDT,GLOBAL)

 +31               NEW CPT,EDT,TDT,GBL

 +32               SET CPT=CPTTAX1_$CHAR(29)_CPTTAX_$CHAR(29)_CPTTAX2

 +33               SET EDT=EDATE_$CHAR(29)_EDATE_$CHAR(29)_EDATE

 +34      ;S TDT=TDT_$C(29)_TDT_$C(29)_TDT

 +35               SET TDT=TOBDT_$CHAR(29)_TOBDT_$CHAR(29)_TOBDT

 +36               SET GBL=GLOBAL_$CHAR(29)_GLOBAL1_$CHAR(29)_GLOBAL2

 +37               DO CPTTAX^BKMIXX(BKMDFN,CPT,EDT,TDT,GBL)

 +38               KILL CPT,EDT,TDT,GBL

 +39               DO ICDTAX^BKMIXX1(BKMDFN,ICDTAX,EDATE,TOBDT,GLOBAL1)

 +40      ;D CPTTAX^BKMIXX(BKMDFN,CPTTAX,EDATE,TOBDT,GLOBAL1)

 +41      ;ED.5

 +42      ;D CPTTAX^BKMIXX(BKMDFN,CPTTAX2,EDATE,TOBDT,GLOBAL2)

 +43      ; DX.12 only. Include problem list.

 +44               DO PRBTAX^BKMIXX(BKMDFN,ICDTAX,EDATE,TOBDT,GLOBAL1)

 +45      ;S.4 and ED.5

 +46               DO ADATAX^BKMIXX(BKMDFN,ADATAX,EDATE,TOBDT,GLOBAL)

 +47      ;D ADATAX^BKMIXX(BKMDFN,ADATAX,EDATE,TOBDT,GLOBAL2)

 +48               MERGE @GL2=@GL

 +49      ;S.4 and ED.5

 +50               DO PTEDTAX^BKMIXX(BKMDFN,PTEDTAX,EDATE,TOBDT,GLOBAL,"","","",.BKMSVTX)

 +51      ;D PTEDTAX^BKMIXX(BKMDFN,PTEDTAX,EDATE,TOBDT,GLOBAL2)

 +52               MERGE @GL2=@GL

 +53      ;S.4 and ED.5

 +54               DO CLNTAX^BKMIXX2(BKMDFN,CLINIC,EDATE,TOBDT,GLOBAL)

 +55               DO CLNTAX^BKMIXX2(BKMDFN,CLINIC,EDATE,TOBDT,GLOBAL2)

 +56      ;S.4

 +57               DO HFTAX^BKMIXX(BKMDFN,HFTAX,EDATE,TOBDT,GLOBAL)

 +58      ;DX.12

 +59               DO HFTAX^BKMIXX(BKMDFN,HFTAX1,EDATE,TOBDT,GLOBAL1)

 +60      ;DX.7

 +61               DO HFTAX^BKMIXX(BKMDFN,HFTAX2,EDATE,TOBDT,GLOBAL3)

 +62               IF $DATA(@GLOB@("HIVCHK",BKMDFN,"TOB"))

                       SET @TOTPTS=@TOTPTS+1

               End DoDot:1

 +63       QUIT

SUBS01    ; EP - Substance Abuse

 +1        NEW SUBS01DT,ICDTAX,ICDTAX2,ICDTAX3,HFTAX,PTEDTAX,GLOBAL,GLOBAL1,TOTPTS,BKMDFN,BKMSVTX

 +2        NEW CD,BHP,BHPRB,MSR

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

 +4       ;S.1

 +5        SET CPTTAX="BGP ALCOHOL SCREENING CPTS"

 +6        SET ICDTAX="BQI ALCOHOL SCREEN DXS"

 +7        SET ICDTAX2="BGP ALCOHOL DXS"

 +8        SET PRCTAX="BQI ALCOHOL PROCEDURES"

 +9        SET HFTAX="BGP ALCOHOL HLTH FACTOR"

 +10       SET PTEDTAX="CD-,-CD,AOD-,-AOD"

 +11      ;S.3

 +12       SET ICDTAX3="BKM OTHER SUBSTANCE ABUSE DXS"

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

 +14      ; IHS does not want Substance Abuse sub-totals originally requested

 +15      ; S GLOBAL1=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""SUBS01CURR"",VSTDT,TEST)"

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

 +17       SET BKMDFN=0

           SET @TOTPTS=0

 +18       FOR

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

               IF 'BKMDFN

                   QUIT

               Begin DoDot:1

 +19      ;S.1

 +20               DO ICDTAX^BKMIXX1(BKMDFN,ICDTAX,EDATE,SUBS01DT,GLOBAL)

 +21               DO ICDTAX^BKMIXX1(BKMDFN,ICDTAX2,EDATE,SUBS01DT,GLOBAL)

 +22      ; D ICDTAX^BKMIXX1(BKMDFN,ICDTAX2,EDATE,SUBS01DT,GLOBAL1)

 +23               DO CPTTAX^BKMIXX(BKMDFN,CPTTAX,EDATE,SUBS01DT,GLOBAL)

 +24               DO PRCTAX^BKMIXX1(BKMDFN,PRCTAX,EDATE,SUBS01DT,GLOBAL)

 +25               DO HFTAX^BKMIXX(BKMDFN,HFTAX,EDATE,SUBS01DT,GLOBAL)

 +26               DO PTEDTAX^BKMIXX(BKMDFN,PTEDTAX,EDATE,SUBS01DT,GLOBAL,"","","",.BKMSVTX)

 +27               DO EXAMTAX^BKMIXX1(BKMDFN,"35",EDATE,SUBS01DT,GLOBAL)

 +28               FOR CD=10,27,29

                       SET BHP(CD)=""

 +29               DO BHPTAX^BKMIXX2(BKMDFN,.BHP,EDATE,SUBS01DT,GLOBAL)

 +30               FOR CD=29.1

                       SET BHPRB(CD)=""

 +31               DO BHPRBTAX^BKMIXX2(BKMDFN,.BHPRB,EDATE,SUBS01DT,GLOBAL)

 +32               FOR CD="AUDT","AUDC","CRFT"

                       SET MSR(CD)=""

 +33               DO MSRTAX^BKMIXX2(BKMDFN,.MSR,EDATE,SUBS01DT,GLOBAL)

 +34      ;S.3

 +35      ;D ICDTAX^BKMIXX1(BKMDFN,ICDTAX3,EDATE,SUBS01DT,GLOBAL1)

 +36               DO ICDTAX^BKMIXX1(BKMDFN,ICDTAX3,EDATE,SUBS01DT,GLOBAL)

 +37               IF $DATA(@GLOB@("HIVCHK",BKMDFN,"SUBS01"))!$DATA(@GLOB@("HIVCHK",BKMDFN,"SUBS01CURR"))

                       SET @TOTPTS=@TOTPTS+1

               End DoDot:1

 +38       QUIT

BKMQQCR5.m