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

BKMVSUP2.m

Go to the documentation of this file. 
  1. BKMVSUP2 ;PRXM/HC/WOM - Continuation of BKMVSUP, HIV SUPPLEMENT; 10 Jun 2005  12:33 PM
  1.  ;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
  1.  Q
  1.  ; Beginning of Immunizations
  1. IMM(DFN) ; EP - Retrieve HAART Appropriate and Compliance Data
  1.  I LNCNT>(MAXCT-2) D NEWPG^BKMVSUP
  1.  D UPD^BKMVSUP
  1.  S LINE=" LAST DOCUMENTED IMMUNIZATIONS: " D UPD^BKMVSUP,BLANK^BKMVSUP(1)
  1.  D IMFIND(DFN)
  1.  D BLANK^BKMVSUP(1)
  1.  I LNCNT>(MAXCT-4) D NEWPG^BKMVSUP
  1.  N BKMIEN1,BKMIEN2,B1,HAAR,HAART,HAARS,HAARDT,BKMIENS,BKMDT,OK
  1.  S HAART="",BKMIEN1="B"
  1.  S LINE=" RECENT MEDICATIONS (past 4 months): " D UPD^BKMVSUP,BLANK^BKMVSUP(1)
  1.  S LINE=" ARV Status: " D UPD^BKMVSUP
  1.  ; Build HAAR array to capture HAART Appropriate and Compliance Data
  1.  F  S BKMIEN1=$O(^BKM(90451,BKMIEN,1,BKMIEN1),-1) Q:'BKMIEN1  D
  1.  . S BKMDT=$$FMADD^XLFDT(DT,-122) ;Look at last 4 months
  1.  . F  S BKMDT=$O(^BKM(90451,BKMIEN,1,BKMIEN1,40,"B",BKMDT)) Q:'BKMDT  D
  1.  .. S BKMIEN2="" F  S BKMIEN2=$O(^BKM(90451,BKMIEN,1,BKMIEN1,40,"B",BKMDT,BKMIEN2)) Q:'BKMIEN2  D
  1.  ... S HAART=HAART+1
  1.  ... D GETS^DIQ(90451.03,BKMIEN2_","_BKMIEN1_","_BKMIEN_",",".01;1;2;3","IE","HAAR("_HAART_")")
  1.  ... ; Confirm that there is something to be printed
  1.  ... S OK=0 D  Q:'OK
  1.  .... I $G(HAAR(HAART,90451.03,BKMIEN2_","_BKMIEN1_","_BKMIEN_",",1,"I"))]"" S OK=1 Q
  1.  .... I $G(HAAR(HAART,90451.03,BKMIEN2_","_BKMIEN1_","_BKMIEN_",",2,"E"))]"" S OK=1 Q
  1.  .... I $G(HAAR(HAART,90451.03,BKMIEN2_","_BKMIEN1_","_BKMIEN_",",3,"E"))]"" S OK=1 Q
  1.  ... S HAARS(HAAR(HAART,90451.03,BKMIEN2_","_BKMIEN1_","_BKMIEN_",",.01,"I"),HAART,BKMIEN2_","_BKMIEN1_","_BKMIEN_",")=""
  1.  ; Sort data by appropriate date and print in reverse date order
  1.  I $D(HAARS) D  K HAARS
  1.  . S HAARDT=""
  1.  . F  S HAARDT=$O(HAARS(HAARDT),-1) Q:HAARDT=""  D
  1.  .. S HAART=""
  1.  .. F  S HAART=$O(HAARS(HAARDT,HAART)) Q:HAART=""  D
  1.  ... S BKMIENS=""
  1.  ... F  S BKMIENS=$O(HAARS(HAARDT,HAART,BKMIENS)) Q:BKMIENS=""  D
  1.  .... I LNCNT>(MAXCT-2) D NEWPG^BKMVSUP
  1.  .... S LINE="   ARV Appropriate: "_$$FMTE^XLFDT(HAARDT,"5Z")_"  "
  1.  .... S LINE=LINE_HAAR(HAART,90451.03,BKMIENS,1,"E")_"  "_HAAR(HAART,90451.03,BKMIENS,2,"E") D UPD^BKMVSUP
  1.  .... S LINE="   Comment: "_HAAR(HAART,90451.03,BKMIENS,3,"I") D UPD^BKMVSUP
  1.  I $D(HAAR) D BLANK^BKMVSUP(1)
  1.  S BKMIEN1="B"
  1.  F  S BKMIEN1=$O(^BKM(90451,BKMIEN,1,BKMIEN1),-1) Q:'BKMIEN1  D
  1.  . S BKMDT=$$FMADD^XLFDT(DT,-183) ;Look at last 6 months
  1.  . F  S BKMDT=$O(^BKM(90451,BKMIEN,1,BKMIEN1,50,"B",BKMDT)) Q:'BKMDT  D
  1.  .. S BKMIEN2="" F  S BKMIEN2=$O(^BKM(90451,BKMIEN,1,BKMIEN1,50,"B",BKMDT,BKMIEN2)) Q:'BKMIEN2  D
  1.  ... S HAART=HAART+1
  1.  ... D GETS^DIQ(90451.07,BKMIEN2_","_BKMIEN1_","_BKMIEN_",",".01;1;2","IE","HAAR("_HAART_")")
  1.  ... ; Confirm that there is something to be printed
  1.  ... S OK=0 D  Q:'OK
  1.  .... I $G(HAAR(HAART,90451.07,BKMIEN2_","_BKMIEN1_","_BKMIEN_",",1,"E"))]"" S OK=1 Q
  1.  .... I $G(HAAR(HAART,90451.07,BKMIEN2_","_BKMIEN1_","_BKMIEN_",",2,"I"))]"" S OK=1 Q
  1.  ... S HAARS(HAAR(HAART,90451.07,BKMIEN2_","_BKMIEN1_","_BKMIEN_",",.01,"I"),HAART,BKMIEN2_","_BKMIEN1_","_BKMIEN_",")=""
  1.  ; Sort data by appropriate date and print in reverse date order
  1.  I $D(HAARS) D  K HAARS
  1.  . S HAARDT=""
  1.  . F  S HAARDT=$O(HAARS(HAARDT),-1) Q:HAARDT=""  D
  1.  .. S HAART=""
  1.  .. F  S HAART=$O(HAARS(HAARDT,HAART)) Q:HAART=""  D
  1.  ... S BKMIENS=""
  1.  ... F  S BKMIENS=$O(HAARS(HAARDT,HAART,BKMIENS)) Q:BKMIENS=""  D
  1.  .... I LNCNT>(MAXCT-2) D NEWPG^BKMVSUP
  1.  .... S LINE="   ARV Adherence: "_$$FMTE^XLFDT(HAARDT,"5Z")_"  "_HAAR(HAART,90451.07,BKMIENS,1,"E")
  1.  .... D UPD^BKMVSUP
  1.  .... S LINE="   Comment: "_HAAR(HAART,90451.07,BKMIENS,2,"I") D UPD^BKMVSUP
  1.  I '$D(HAAR) D
  1.  . I LNCNT>(MAXCT-2) D NEWPG^BKMVSUP
  1.  . D UPD^BKMVSUP S LINE="   ARV Appropriate:" D UPD^BKMVSUP
  1.  . S LINE="   ARV Adherence:"
  1.  K HAAR
  1.  D UPD^BKMVSUP,BLANK^BKMVSUP(1)
  1.  I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  Q
  1. IMFIND(DFN) ; Return recent immunizations in ^TMP("BKMSUPP",$J,1)
  1.  N BKMIM,IMARR,IMIEN
  1.  D PNE(DFN)
  1.  D FLU(DFN)
  1.  D HEPA(DFN)
  1.  D HEPB(DFN)
  1.  D CMV(DFN)
  1.  D TET(DFN)
  1.  Q
  1. PNE(DFN) ; Retrieve Pneumococcal taxonomies (IZ.6)
  1.  S LINE=" Pneumococcal: "
  1.  K BKMT("PNE")
  1.  S GLOBAL="BKMT(""PNE"",VSTDT,TEST,""CPT"")"
  1.  D CPTTAX^BKMIXX(DFN,"BGP PNEUMO IZ CPTS","","",GLOBAL)
  1.  S GLOBAL="BKMT(""PNE"",VSTDT,TEST,""ICD"")"
  1.  D ICDTAX^BKMIXX1(DFN,"BQI PNEUMO IZ DXS","","",GLOBAL)
  1.  S GLOBAL="BKMT(""PNE"",VSTDT,TEST,""PROC"")"
  1.  D PRCTAX^BKMIXX1(DFN,"BQI PNEUMO IZ PROCEDURES","","",GLOBAL)
  1.  S GLOBAL="BKMT(""PNE"",VSTDT,TEST,""CVX"")"
  1.  D CVXTAX^BKMIXX1(DFN,"BKM PNEUMO IZ CVX CODES","","",GLOBAL) ;***
  1.  I $D(BKMT("PNE")) D LTAXPRT^BKMVSUP1("PNE",1) K BKMT("PNE") D UPD^BKMVSUP:LINE'="" Q
  1.  ; Check refusals
  1.  D REFUSAL^BKMIXX2(DFN,9999999.14,"BKM PNEUMO IZ CVX CODES","","",GLOBAL)
  1.  ; Print results
  1.  D LTAXPRT^BKMVSUP1("PNE",1,1,1)
  1.  K BKMT("PNE")
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. FLU(DFN) ; Retrieve Influenza taxonomies (IZ.5)
  1.  S LINE=" Influenza: "
  1.  K BKMT("FLU")
  1.  S GLOBAL="BKMT(""FLU"",VSTDT,TEST,""CPT"")"
  1.  D CPTTAX^BKMIXX(DFN,"BGP CPT FLU","","",GLOBAL)
  1.  S GLOBAL="BKMT(""FLU"",VSTDT,TEST,""ICD"")"
  1.  D ICDTAX^BKMIXX1(DFN,"BQI FLU IZ DXS","","",GLOBAL)
  1.  S GLOBAL="BKMT(""FLU"",VSTDT,TEST,""PROC"")"
  1.  D PRCTAX^BKMIXX1(DFN,"BQI FLU IZ PROCEDURES","","",GLOBAL)
  1.  S GLOBAL="BKMT(""FLU"",VSTDT,TEST,""CVX"")"
  1.  D CVXTAX^BKMIXX1(DFN,"BGP FLU IZ CVX CODES","","",GLOBAL)
  1.  I $D(BKMT("FLU")) D LTAXPRT^BKMVSUP1("FLU",1) K BKMT("FLU") D UPD^BKMVSUP:LINE'="" Q
  1.  ; Check refusals
  1.  D REFUSAL^BKMIXX2(DFN,9999999.14,"BGP FLU IZ CVX CODES","","",GLOBAL)
  1.  ; Print results
  1.  D LTAXPRT^BKMVSUP1("FLU",1,1,1)
  1.  K BKMT("FLU")
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. HEPA(DFN) ; Retrieve Hepatitis A taxonomies (IZ.3)
  1.  S LINE=" Hepatitis A (last 2): "
  1.  ;S LINE=$$LINE^BKMVSUP(LINE,"Dx Date: ",24)
  1.  K BKMT("HEPADX") N HEPDT
  1.  S GLOBAL="BKMT(""HEPADX"",VSTDT,TEST,""ICD"")"
  1.  D ICDTAX^BKMIXX1(DFN,"BKM HEP A DXS","","",GLOBAL)
  1.  D PRBTAX^BKMIXX(DFN,"BKM HEP A DXS","","",GLOBAL)
  1.  I $D(BKMT("HEPADX")) D  K BKMT("HEPADX")
  1.  . S HEPDT=$O(BKMT("HEPADX",""),-1)
  1.  . I HEPDT S LINE=LINE_$$FMTE^XLFDT(HEPDT\1,"5Z")_"  "
  1.  . S LINE=LINE_$P(@$Q(BKMT("HEPADX")),U,2)
  1.  K BKMT("HEPA")
  1.  S GLOBAL="BKMT(""HEPA"",VSTDT,TEST,""CPT"")"
  1.  D CPTTAX^BKMIXX(DFN,"BKM HEP A IZ CPTS","","",GLOBAL)
  1.  S GLOBAL="BKMT(""HEPA"",VSTDT,TEST,""CVX"")"
  1.  D CVXTAX^BKMIXX1(DFN,"BKM HEP A IZ CVX CODES","","",GLOBAL)
  1.  I $D(BKMT("HEPA")) D LTAXPRT^BKMVSUP1("HEPA",2,"","","","",1,"Dx Date: ") K BKMT("HEPA") D UPD^BKMVSUP:LINE'="" Q
  1.  ; Check refusals
  1.  D REFUSAL^BKMIXX2(DFN,9999999.14,"BKM HEP A IZ CVX CODES","","",GLOBAL)
  1.  ; Print results
  1.  D LTAXPRT^BKMVSUP1("HEPA",2,1,1,,,,"Dx Date: ")
  1.  K BKMT("HEPA")
  1.  I LINE=" Hepatitis A (last 2): " S LINE=$$LINE^BKMVSUP(LINE,"Dx Date: ",24)
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. HEPB(DFN) ; Retrieve Hepatitis B taxonomies (IZ.4)
  1.  D BLANK^BKMVSUP(1)
  1.  S LINE=" Hepatitis B (last 3): "
  1.  K BKMT("HEPBDX") N HEPDT
  1.  S GLOBAL="BKMT(""HEPBDX"",VSTDT,TEST,""ICD"")"
  1.  D ICDTAX^BKMIXX1(DFN,"BKM HEP B DXS","","",GLOBAL)
  1.  D PRBTAX^BKMIXX(DFN,"BKM HEP B DXS","","",GLOBAL)
  1.  I $D(BKMT("HEPBDX")) D  K BKMT("HEPBDX")
  1.  . S HEPDT=$O(BKMT("HEPBDX",""),-1)
  1.  . I HEPDT S LINE=LINE_$$FMTE^XLFDT(HEPDT\1,"5Z")_"  " ;W $$FMTE^XLFDT(HEPDT\1,"5Z"),"  "
  1.  . S LINE=LINE_$P(@$Q(BKMT("HEPBDX")),U,2)
  1.  K BKMT("HEPB")
  1.  S GLOBAL="BKMT(""HEPB"",VSTDT,TEST,""CPT"")"
  1.  D CPTTAX^BKMIXX(DFN,"BKM HEP B IZ CPTS","","",GLOBAL)
  1.  S GLOBAL="BKMT(""HEPB"",VSTDT,TEST,""CVX"")"
  1.  D CVXTAX^BKMIXX1(DFN,"BKM HEP B IZ CVX CODES","","",GLOBAL)
  1.  I $D(BKMT("HEPB")) D LTAXPRT^BKMVSUP1("HEPB",3,"","","","",1,"Dx Date: ") K BKMT("HEPB") D UPD^BKMVSUP:LINE'="" Q
  1.  ; Check refusals
  1.  D REFUSAL^BKMIXX2(DFN,9999999.14,"BKM HEP B IZ CVX CODES","","",GLOBAL)
  1.  ; Print results
  1.  D LTAXPRT^BKMVSUP1("HEPB",3,1,1,,,,"Dx Date: ")
  1.  K BKMT("HEPB")
  1.  I LINE=" Hepatitis B (last 3): " S LINE=$$LINE^BKMVSUP(LINE,"Dx Date: ",24)
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. CMV(DFN) ; Retrieve CMV(IgG) taxonomies (T.6)
  1.  ; Disabled as per IHS
  1.  Q
  1.  D BLANK^BKMVSUP(1)
  1.  S LINE=" CMV (IgG): "
  1.  K BKMT("CMV")
  1.  S GLOBAL="BKMT(""CMV"",VSTDT,TEST,""CPT"")"
  1.  D CPTTAX^BKMIXX(DFN,"BKM CMV IZ CPTS","","",GLOBAL)
  1.  S GLOBAL="BKMT(""CMV"",VSTDT,TEST,""CVX"")"
  1.  D CVXTAX^BKMIXX1(DFN,"BKM CMV IZ CVX CODES","","",GLOBAL)
  1.  I $D(BKMT("CMV")) D LTAXPRT^BKMVSUP1("CMV",1) K BKMT("CMV") D UPD^BKMVSUP:LINE'="" Q
  1.  ; Check refusals
  1.  D REFUSAL^BKMIXX2(DFN,9999999.14,"BKM CMV IZ CVX CODES","","",GLOBAL)
  1.  ; Print results
  1.  D LTAXPRT^BKMVSUP1("CMV",1,1,1)
  1.  K BKMT("CMV")
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. TET(DFN) ; Retrieve Tetanus taxonomies (IZ.7)
  1.  S LINE=" Tetanus: "
  1.  K BKMT("TET")
  1.  S GLOBAL="BKMT(""TET"",VSTDT,TEST,""CPT"")"
  1.  D CPTTAX^BKMIXX(DFN,"BKM TETANUS IZ CPTS","","",GLOBAL)
  1.  S GLOBAL="BKMT(""TET"",VSTDT,TEST,""ICD"")"
  1.  D ICDTAX^BKMIXX1(DFN,"BKM TETANUS IZ DXS","","",GLOBAL)
  1.  S GLOBAL="BKMT(""TET"",VSTDT,TEST,""PROC"")"
  1.  D PRCTAX^BKMIXX1(DFN,"BKM TETANUS IZ PROCEDURES","","",GLOBAL)
  1.  S GLOBAL="BKMT(""TET"",VSTDT,TEST,""CVX"")"
  1.  D CVXTAX^BKMIXX1(DFN,"BKM TETANUS IZ CVX CODES","","",GLOBAL)
  1.  I $D(BKMT("TET")) D LTAXPRT^BKMVSUP1("TET",1) K BKMT("TET") D UPD^BKMVSUP:LINE'="" Q
  1.  ; Check refusals
  1.  D REFUSAL^BKMIXX2(DFN,9999999.14,"BKM TETANUS IZ CVX CODES","","",GLOBAL)
  1.  ; Print results
  1.  D LTAXPRT^BKMVSUP1("CMV",1,1,1)
  1.  K BKMT("TET")
  1.  I LINE'="" D UPD^BKMVSUP
  1.  Q
  1. SCREENS(DFN) ; EP - Get screens from taxonomies
  1.  ; Several calls below used to use $H-360.
  1.  ; Replaced with BKMCKDT (FileMan format date).
  1.  N BKMCKDT,CODETP
  1.  S BKMCKDT=$$FMADD^XLFDT(DT,-360)
  1.  ; Variable MAXCT is set by PRINT^BKMVSUP
  1.  D UPD^BKMVSUP
  1.  I LNCNT>(MAXCT-2) D NEWPG^BKMVSUP
  1.  D UPD^BKMVSUP S LINE=" IN THE PAST 12 MONTHS:" D UPD^BKMVSUP
  1.  N GLOBAL1,GLOBAL2,GLOBAL3,CODE,Y,BKMDT,CD,BHP ;K ^TMP("BKMSUPP",$J)
  1. DEP ; Depression Screening (S.2)
  1.  K BKMT("DSC")
  1.  S GLOBAL1="BKMT(""DSC"",DFN,VSTDT,TEST,""POV"")"
  1.  S GLOBAL2="BKMT(""DSC"",DFN,VSTDT,TEST,""EX"")",CODETP=""
  1.  S GLOBAL3="BKMT(""DSC"",DFN,VSTDT,TEST,""BHS"")"
  1.  D ICDTAX^BKMIXX1(DFN,"BGP MOOD DISORDERS","",BKMCKDT,GLOBAL1) ; Requested by IHS as part of S.2
  1.  D ICDTAX^BKMIXX1(DFN,"BQI DEPRESSION SCREEN DXS","",BKMCKDT,GLOBAL1)
  1.  ;D POVTAX^BKMIXX2(DFN,"V79.0","",BKMCKDT,GLOBAL1) ; Requested by IHS as part of S.2
  1.  ;SNOMED
  1.  D EXAMTAX^BKMIXX1(DFN,"36","",BKMCKDT,GLOBAL2) ; Requested by IHS as part of S.2
  1.  F CD=14.1 S BHP(CD)=""
  1.  D BHPRBTAX^BKMIXX2(DFN,.BHP,"",BKMCKDT,GLOBAL3)
  1.  S BKMDT=$O(BKMT("DSC",DFN,""),-1),Y=BKMDT,Y=$$FMTE^XLFDT(Y,"5Z")
  1.  S CODE="" S:BKMDT'="" CODE=$O(BKMT("DSC",DFN,BKMDT,""))
  1.  I CODE'="" D
  1.  . S CODETP=$O(BKMT("DSC",DFN,BKMDT,CODE,""))
  1.  . S CODE=$P(BKMT("DSC",DFN,BKMDT,CODE,CODETP),U,2),CODETP=CODETP_": "
  1.  S LINE=" Depression Screening: ",LINE=$$LINE^BKMVSUP(LINE,"Date: ",24)_$P(Y,"@")
  1.  S LINE=$$LINE^BKMVSUP(LINE,CODETP_$E(CODE,1,30),42) D UPD^BKMVSUP
  1.  I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  K BKMT("DSC")
  1.  ;
  1. IPV ; Intimate Partner/Domestic Violence Screening
  1.  N SEX
  1.  K BKMT("VSC")
  1.  S SEX=$$GET1^DIQ(2,DFN,.02,"I"),CODETP=""
  1.  I SEX="M" D
  1.  . S LINE=" IPV/DV Screening: Not Applicable"
  1.  I SEX'="M" D
  1.  . S GLOBAL1="BKMT(""VSC"",DFN,VSTDT,TEST,""POV"")"
  1.  . S GLOBAL2="BKMT(""VSC"",DFN,VSTDT,TEST,""PED"")"
  1.  . S GLOBAL3="BKMT(""VSC"",DFN,VSTDT,TEST,""EX"")"
  1.  . D ICDTAX^BKMIXX1(DFN,"BGP IPV/DV COUNSELING ICDS","",BKMCKDT,GLOBAL1)
  1.  . D ICDTAX^BKMIXX1(DFN,"BGP DV DXS","",BKMCKDT,GLOBAL1)
  1.  . D PTEDTAX^BKMIXX(DFN,"DV-,-DV","",BKMCKDT,GLOBAL2) ; Domestic Violence
  1.  . D EXAMTAX^BKMIXX1(DFN,"34","",BKMCKDT,GLOBAL3)
  1.  . S BKMDT=$O(BKMT("VSC",DFN,""),-1),Y=BKMDT,Y=$$FMTE^XLFDT(Y,"5Z")
  1.  . S CODE="" S:BKMDT'="" CODE=$O(BKMT("VSC",DFN,BKMDT,""))
  1.  . I CODE'="" D
  1.  .. S CODETP=$O(BKMT("VSC",DFN,BKMDT,CODE,""))
  1.  .. S CODE=$P(BKMT("VSC",DFN,BKMDT,CODE,CODETP),U,2),CODETP=CODETP_": "
  1.  . S LINE=" IPV/DV Screening: ",LINE=$$LINE^BKMVSUP(LINE,"Date: ",24)_$P(Y,"@")
  1.  . S LINE=$$LINE^BKMVSUP(LINE,CODETP_$E(CODE,1,30),42)
  1.  D UPD^BKMVSUP
  1.  K BKMT("VSC")
  1.  I LNCNT>MAXCT D NEWPG^BKMVSUP
  1. ALC ; Alcohol Screening (S.1)
  1.  K BKMT("ASC")
  1.  N GLOBAL1,GLOBAL2,GLOBAL3,GLOBAL4,GLOBAL5,GLOBAL6,GLOBAL7,GLOBAL8
  1.  N CD,BHP,MSR
  1.  S GLOBAL1="BKMT(""ASC"",DFN,VSTDT,TEST,""POV"")",CODETP=""
  1.  S GLOBAL2="BKMT(""ASC"",DFN,VSTDT,TEST,""HF"")"
  1.  S GLOBAL3="BKMT(""ASC"",DFN,VSTDT,TEST,""PED"")"
  1.  S GLOBAL4="BKMT(""ASC"",DFN,VSTDT,TEST,""EX"")"
  1.  S GLOBAL5="BKMT(""ASC"",DFN,VSTDT,TEST,""CPT"")"
  1.  S GLOBAL6="BKMT(""ASC"",DFN,VSTDT,TEST,""PRC"")"
  1.  S GLOBAL7="BKMT(""ASC"",DFN,VSTDT,TEST,""BHP"")"
  1.  S GLOBAL8="BKMT(""ASC"",DFN,VSTDT,TEST,""MSR"")"
  1.  D ICDTAX^BKMIXX1(DFN,"BQI ALCOHOL SCREEN DXS","",BKMCKDT,GLOBAL1)
  1.  D ICDTAX^BKMIXX1(DFN,"BGP ALCOHOL DXS","",BKMCKDT,GLOBAL1)
  1.  D CPTTAX^BKMIXX(DFN,"BGP ALCOHOL SCREENING CPTS","",BKMCKDT,GLOBAL5)
  1.  ;D PRCTAX^BKMIXX1(DFN,"BGP ALCOHOL PROCEDURES","",BKMCKDT,GLOBAL6)
  1.  D PRCTAX^BKMIXX1(DFN,"BQI ALCOHOL PROCEDURES","",BKMCKDT,GLOBAL6)
  1.  D HFTAX^BKMIXX(DFN,"BGP ALCOHOL HLTH FACTOR","",BKMCKDT,GLOBAL2)
  1.  D PTEDTAX^BKMIXX(DFN,"CD-,-CD,AOD-,-AOD","",BKMCKDT,GLOBAL3) ; Alcohol
  1.  D EXAMTAX^BKMIXX1(DFN,"35","",BKMCKDT,GLOBAL4)
  1.  F CD=29.1,10,27,29 S BHP(CD)=""
  1.  D BHPTAX^BKMIXX2(DFN,.BHP,"",BKMCKDT,GLOBAL7)
  1.  F CD="AUDT","AUDC","CRFT" S MSR(CD)=""
  1.  D MSRTAX^BKMIXX2(DFN,.MSR,"",BKMCKDT,GLOBAL8)
  1.  S BKMDT=$O(BKMT("ASC",DFN,""),-1),Y=BKMDT,Y=$$FMTE^XLFDT(Y,"5Z")
  1.  S CODE="" S:BKMDT'="" CODE=$O(BKMT("ASC",DFN,BKMDT,""))
  1.  I CODE'="" D
  1.  . S CODETP=$O(BKMT("ASC",DFN,BKMDT,CODE,""))
  1.  . S CODE=$P(BKMT("ASC",DFN,BKMDT,CODE,CODETP),U,2),CODETP=CODETP_": "
  1.  S LINE=" Alcohol Screening: ",LINE=$$LINE^BKMVSUP(LINE,"Date: ",24)_$P(Y,"@")
  1.  S LINE=$$LINE^BKMVSUP(LINE,CODETP_$E(CODE,1,30),42) D UPD^BKMVSUP
  1.  K BKMT("ASC")
  1.  I LNCNT>MAXCT D NEWPG^BKMVSUP
  1.  Q
  1. HTWT(DFN) ; EP - HEIGHT/WEIGHT
  1.  Q:'$D(^AUPNVMSR("AC",DFN)) "^"
  1.  N HT,WT,TYP
  1.  S (HT,WT)=""
  1.  S TYP=$$FIND1^DIC(9999999.07,,"X","HT")
  1.  I TYP S HT=$$MSRVAL(TYP)
  1.  S TYP=$$FIND1^DIC(9999999.07,,"X","WT")
  1.  I TYP S WT=$$MSRVAL(TYP)
  1.  Q HT_"^"_WT
  1.  ;
  1. MSRVAL(TYP) ; Return most recent value based on type of measurement passed
  1.  N VAL,BKMIDT,BKMIM,DT,QFL,MVAL
  1.  S VAL="",QFL=0
  1.  S BKMIDT=$O(^AUPNVMSR("AA",DFN,TYP,"")) I BKMIDT="" Q "^"
  1.  S BKMIM="",MVAL="^"
  1.  F  S BKMIM=$O(^AUPNVMSR("AA",DFN,TYP,BKMIDT,"")) Q:BKMIM=""!(QFL)  D
  1.  . S TYP=$P($G(^AUPNVMSR(BKMIM,0)),U,4)
  1.  . I $P($G(^AUPNVMSR(BKMIM,2)),U,1)=1 Q
  1.  . S MVAL=TYP_"^"_$$FMTE^XLFDT(9999999-BKMIDT,"5Z"),QFL=1
  1.  Q MVAL
  1.  ;
  1. XIT ; QUIT POINT
  1.  Q