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