BDMDG18 ; IHS/CMI/LAB - 2019 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
;
;
HT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,BDMARRY,H,E,D,W
S E=$O(^AUTTMSR("B","HT",0))
S H=""
S D=0 F S D=$O(^AUPNVMSR("AA",P,E,D)) Q:D'=+D!(H]"") D
.S W=0 F S W=$O(^AUPNVMSR("AA",P,E,D,W)) Q:W'=+W!(H]"") D
..Q:'$D(^AUPNVMSR(W,0))
..Q:$P($G(^AUPNVMSR(W,2)),U,1) ;entered in error
..S H=$P(^AUPNVMSR(W,0),U,4)
..S BDMARRAY(1)=$$VD^APCLV($P(^AUPNVMSR(W,0),U,3))
I H="" Q H
I H["?" Q ""
S H=$J(H,5,2)
Q $$STRIP^XLFSTR(H," ")
;
WT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD,BDMVF
K BDM S BDMW="" S BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")
S BDMN=0 F S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMW]"") D
.S BDMVF=+$P(BDM(BDMN),U,4)
.Q:$P($G(^AUPNVMSR(BDMVF,2)),U,1) ;entered in error
.S BDMZ=$P(BDM(BDMN),U,5)
.I '$D(^AUPNVPOV("AD",BDMZ)) S BDMW=$P(BDM(BDMN),U,2) Q
.S BDMD=0,G=0 F S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD!(G=1) D
..S ICD=$$VALI^XBDIQ1(9000010.07,BDMD,.01) D ;cmi/anch/maw 9/12/2007 csv
...I $$ICD^BDMUTL(ICD,"BGP PREGNANCY DIAGNOSES 2",9) S G=1 ;cmi/maw 05/15/2014 p8
.I 'G S BDMW=$P(BDM(BDMN),U,2)
Q BDMW
BMI(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,W,H,B,D,%DT,X
S %=""
D Q %
.S W=$$WT(P,BDATE,EDATE) Q:W="" S W=W\1 ;S W=W+.5,W=$P(W,".")
.S HDATE=$P(^DPT(P,0),U,3)
.S H=$$HT(P,HDATE,EDATE) I H="" Q
.;S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
.S H=H*H,%=(W/H)*703,%=$J(%,5,1)
.Q
Q
CREAT(P,BDATE,EDATE,F) ;EP
G CREAT^BDMDG1C
CHOL(P,BDATE,EDATE,F) ;EP
G CHOL^BDMDG1C
HDL(P,BDATE,EDATE,F) ;EP
G HDL^BDMDG1C
LDL(P,BDATE,EDATE,F) ;EP
G LDL^BDMDG1C
TRIG(P,BDATE,EDATE,F) ;EP
G TRIG^BDMDG1C
URIN(P,BDATE,EDATE) ;EP
G URIN^BDMDG1H
PROTEIN(P,BDATE,EDATE) ;EP
G PROTEIN^BDMDG1C
MICRO(P,BDATE,EDATE) ;EP
G MICRO^BDMDG1C
HGBA1C(P,BDATE,EDATE) ;EP
G HGBA1C^BDMDG1D
SEMI(P,BDATE,EDATE) ;EP
G SEMI^BDMDG1C
PPDS(P) ;
NEW BDMS,E,X
K BDMS
S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BDMS(")
I $D(BDMS) Q 1_U_$$DATE^BDMS9B1($P(BDMS(1),U))_" HF: "_$P(BDMS(1),U,3)
PPDSPL ;CHECK PL
N T S T=$O(^ATXAX("B","DM AUDIT TUBERCULOSIS DXS",0))
I 'T Q ""
;N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=X
N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)),$P(^AUPNPROB(X,0),U,12)'="D" S Y=$P(^AUPNPROB(X,0),U) I $$ICD^BDMUTL(Y,$P(^ATXAX(T,0),U),9) S I=X ;cmi/maw 05/15/2014 p8
I I Q 1_U_$$DATE^BDMS9B1($$VALI^XBDIQ1(9000011,I,.03))_" Problem List: "_$$VAL^XBDIQ1(9000011,I,.01)
;check povs
K BDMS S X=P_"^FIRST DX [DM AUDIT TUBERCULOSIS DXS" S E=$$START1^APCLDF(X,"BDMS(")
I $D(BDMS(1)) Q 1_U_$$DATE^BDMS9B1($P(BDMS(1),U))_" POV: "_$P(BDMS(1),U,3)
Q ""
PPD(P,EDATE,F) ;EP
;f 1=tb test done
;f 2=tb result
S F=$G(F)
;RETURN 1^1 Skin Test||1 Positive
NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED,LD,LR
S LD="",LR=""
S X=EDATE,%DT="P" D ^%DT S ED=Y
S G=$$PPDS(P) I G Q "1 TB Positive "_$P(G,U,2)_"||1 Positive TB "_$P(G,U,2) ;IF HAD HF or dx or pl of TB use it as positive
K BDM
;get, in reverse order all skin tests and lab tests for TB testing (BDM(inverse date,#)=ST or LAB^ien^result^reading
S X=$O(^AUTTSK("B","PPD",0))
S D=9999999-ED-1,C=0 F S D=$O(^AUPNVSK("AA",P,X,D)) Q:D="" D
.S G=0 F S G=$O(^AUPNVSK("AA",P,X,D,G)) Q:G'=+G D
..Q:'$D(^AUPNVSK(G,0))
..S C=C+1 S BDM(D,C)="ST"_U_G_U_$P(^AUPNVSK(G,0),U,5)_U_$S($P(^AUPNVSK(G,0),U,4)="D":"",$P(^AUPNVSK(G,0),U,4)="O":"",1:$P(^AUPNVSK(G,0),U,4))
S BDMC=0
S BDMLT=$O(^ATXLAB("B","DM AUDIT TB LAB TESTS",0))
S BDMOT=$O(^ATXAX("B","DM AUDIT TB TEST LOINC",0))
S G="",E=9999999-ED S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)=""
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D
....S C=C+1,BDM(D,C)="LAB^"_X_U_$P(^AUPNVLAB(X,0),U,4),G=1
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BDMDG1C(J,BDMOT)
...S C=C+1,BDM(D,C)="LAB^"_X_U_$P(^AUPNVLAB(X,0),U,4),G=1
...Q
;now get latest with a result and use it, if none with a result take latest one
;if none, quit on value
S (D,C)=0,G=""
F S D=$O(BDM(D)) Q:D'=+D!(G]"") D
.S C=0 F S C=$O(BDM(D,C)) Q:C'=+C!(G]"") D
..I $P(BDM(D,C),U,3)]""!($P(BDM(D,C),U,4)]"") S G=BDM(D,C)
I F="I" Q $S($P(G,U,1)="LAB":$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3)),1:$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3)))
I G]"" S C="" D Q C ;C=1 skin test||result value
.S C=$S($P(G,U,1)="ST":"1 Skin test (PPD)",1:"2 Blood Test (QFT-G, T SPOT-TB)")
.;GET RESULT VALUE
.I $P(G,U,1)="LAB" S R=$P(G,U,3) D Q
..I $E($$UP^XLFSTR(R))="P" S C=C_"||1 Positive "_$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3),"S")_" lab result: "_R Q
..I $E($$UP^XLFSTR(R))="N" S C=C_"||2 Negative "_$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3),"S")_" lab result: "_R Q
..S C=C_"||3 Unknown" Q
.I $P(G,U,1)="ST" D Q
..S R=$P(G,U,3),R1=$P(G,U,4)
..I R]"",R>9 S C=C_"||1 Positive "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
..I R]"",R<10 S C=C_"||2 Negative "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
..I R1]"",R1="P" S C=C_"||1 Positive "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
..I R1]"",R1="N" S C=C_"||2 Negative "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
..;S C=C_"||3 Unknown" Q
Q "3 Unknown||"
;
LASTNP(P,EDATE) ;EP - last negative ppd
I $E($P($$PPD(P,EDATE),"||",2))'="2" Q ""
Q $$PPD(P,EDATE,"I")
;
FGLUCOSE(P,BDATE,EDATE,F) ;EP
G FGLUCOSE^BDMDG1D
G75(P,BDATE,EDATE,F) ;EP
G G75^BDMDG1D
;
STV(X,T,D) ;EP - strip hgba1c before epi export
I X="" Q X ;no value in X so don't bother
I X="?" Q ""
NEW A,B,L
S L=$L(X)
I $E(X)?1N S X=+X
F B=1:1:L S A=$E(X,B) Q:A="" I A'?1N,A'?1"." S X=$$STRIP^XLFSTR(X,A) S B=B-1
I X="" Q ""
I $G(D),X["." S X=$J(X,T,D)
S X=$$STRIP^XLFSTR(X," ")
Q $E(X,1,T)
STE(X,T,D) ;EP - strip hgba1c before epi export
I X="" Q X ;no value in X so don't bother
I X="?" Q ""
NEW A,B,L
S L=$L(X)
F B=1:1:L S A=$E(X,B) Q:A="" I A'?1N,A'?1".",X'?1"+",X'?1"-",X'?1">",X'?1"<" S X=$$STRIP^XLFSTR(X,A) S B=B-1
I X="" Q ""
I $G(D),X["." S X=$J(X,T,D)
S X=$$STRIP^XLFSTR(X," ")
Q $E(X,1,T)
AS(X) ;EP
I $E(X)="<" S X=$E(X,2,99),X=X-1 Q X
I $E(X)=">" S X=$E(X,2,99),X=X+1 Q X
Q X
;
GFRDES(P,BDATE,EDATE,EEGFR) ;EP
NEW A,B,C
S A=$$CALCGFR(P,BDATE,EDATE)
I A="" Q 0
S A=$P(A,U,2)
I $E(A)=">" S C=0 D Q C
.S A=60
.I EEGFR>60 S C=0 Q
.I EEGFR<50 S C=1 Q
S A=$$STV^BDMDG18(A,5,1)
S B=EEGFR-A
I B>10 Q 1
I B<-10 Q 1
Q 0
CALCGFRZ(P,BDATE,EDATE) ;EP
NEW R,C,X,Y,Z,D
S R=$$CREAT^BDMDG18(P,BDATE,EDATE,"I"),D=$P(R,U,2),R=$P(R,U,1)
I R="" Q ""
;CALCULATE IT
S BDMSEX=$P(^DPT(P,0),U,2)
S BDMAGE=$$AGE^AUPNPAT(P,D)
S X=$$GFRSE1CZ(P,R,BDMAGE,BDMSEX)
Q D_U_X_"^ESTIMATED GFR (CALC)"
GFRSE1CZ(DFN,CRET,BDMAGE,BDMSEX) ; EP
;D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("GFRSE1CU^BLREXEC2")
;
S %X=$$CHKERRS ; Check for Errors
I %X'="OK" Q %X ; If NOT OK, quit with error
;
NEW CONSTA,CRETEXP,AGEEXP,SEXFACTR,RACEFACT
D SETVARS1 ; Setup constants & exponents
;
S %X=CONSTA*(CRET**CRETEXP)*(BDMAGE**AGEEXP)*$G(SEXFACTR)*$G(RACEFACT)
;
S %X=$TR($FN(%X,"",0)," ") ;ROUND RESULT
;
; See www.nkdep.nih.gov/resources/laboratory_reporting.htm
;I %X>60 S %X=">60"
;
Q %X
CALCGFR(P,BDATE,EDATE) ;EP
NEW R,C,X,Y,Z,D
S R=$$CREAT^BDMDG18(P,BDATE,EDATE,"I"),D=$P(R,U,2),R=$P(R,U,1)
I R="" Q ""
;CALCULATE IT
S BDMSEX=$P(^DPT(P,0),U,2)
S BDMAGE=$$AGE^AUPNPAT(P,D)
S X=$$GFRSE1CU(P,R,BDMAGE,BDMSEX)
Q D_U_X_"^ESTIMATED GFR (CALC)"
GFRSE1CU(DFN,CRET,BDMAGE,BDMSEX) ; EP
;D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("GFRSE1CU^BLREXEC2")
;
S %X=$$CHKERRS ; Check for Errors
I %X'="OK" Q %X ; If NOT OK, quit with error
;
NEW CONSTA,CRETEXP,AGEEXP,SEXFACTR,RACEFACT
D SETVARS1 ; Setup constants & exponents
;
S %X=CONSTA*(CRET**CRETEXP)*(BDMAGE**AGEEXP)*$G(SEXFACTR)*$G(RACEFACT)
;
S %X=$TR($FN(%X,"",0)," ") ;ROUND RESULT
;
; See www.nkdep.nih.gov/resources/laboratory_reporting.htm
I %X>60 S %X=">60"
;
Q %X
;
CHKERRS() ; EP
N BDMERR
S BDMERR="N/A"
;
I $TR($G(CRET)," ")="" Q BDMERR ; If creatinine null, then quit
;
; If 1st character not numeric, then quit
; I $E($G(CRET))'?1N Q BDMERR
I $G(CRET)?1A.A S %X=BDMERR Q %X ; IHS/OIT/MKK - LR*5.2*1026
;
; Following lines added to handle errors sent by some instruments
; Quit if any are true
I $E($G(CRET))="" Q BDMERR ; If Null
I $E($G(CRET))="#" Q BDMERR ; Out of Range
I $E($G(CRET))="<" Q BDMERR ; Vitros results with "<"
I ($G(CRET))="-" Q BDMERR ; Negative results
;
I +$G(CRET)=0 Q BDMERR ; If zero results, then quit
;
;I AGE["DYS"!(AGE["MOS")!(AGE<17) Q BDMERR ; 16 & younger not done, quit
I BDMAGE<18 Q BDMERR
;
I BDMSEX="" Q BDMERR ; Cannot calculate without SEX
I BDMSEX="U" Q BDMERR
;
Q "OK"
;
SETVARS1 ; EP
;CONSTANTS, EXPONENTS
S SEXFACTR=$S(BDMSEX="M":1,1:.742) ; Sex Factor
;
S RACEFACT=$S($$RACE(DFN)="B":1.21,1:1)
;
S CONSTA=186 ; CONSTANT A
S CRETEXP=-1.154 ; CREATININE EXPONENT
S AGEEXP=-.203 ; AGE EXPONENT
;
;D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("SETVARS1^BLREXEC2")
Q
RACE(DFN) ; EP
NEW RACEPTR,RACEENT,V
;
I $T(RACE^AGUTL)]"" D Q V
.S V=""
.S RACEPTR=$$RACE^AGUTL(DFN)
.I $P(RACEPTR,U)=1,$P(RACEPTR,U,2)["BLACK" S V="B"
.S V="N"
S RACEPTR=$P($G(^DPT(+$G(DFN),0)),U,6)
Q:RACEPTR="" "N" ; If no entry, consider non-black
;
S RACEENT=$P($G(^DIC(10,RACEPTR,0)),U)
Q:RACEENT[("BLACK") "B" ; If RACEENT contains BLACK >= race = Black
Q "N" ; otherwise, non-black
;
PRES(P,TAX,ED) ;EP
;GO THROUGH 52 FOR PATIENT
NEW BDMD,G,Z,R,D,E,T,F,I,BDMMEDS1,Y,%,K,V
S BDMD=$$FMADD^XLFDT(ED,-(6*31)) ;DATE OF EXPIRATION NEEDS TO BE GREATER THAN THIS AND DAYS SUPPLY * REFILLS NEEDS TO BE GREATER THAN THIS ADDED TO ISSUE DATE
S Z=0,G="" F S Z=$O(^PS(55,P,"P",Z)) Q:Z'=+Z!(G="X") D
.S R=$P(^PS(55,P,"P",Z,0),U,1)
.Q:'$D(^PSRX(R,0)) ;bad xref
.Q:$E($P(^PSRX(R,0),U,1))'="X" ;not an external med
.S D=$P(^PSRX(R,0),U,6)
.Q:'D ;no drug??
.Q:'$D(^ATXAX(TAX,21,"B",D)) ;not a drug we care about
.S E=$P($G(^PSRX(R,2)),U,6)
.I E,E<BDMD Q ;expires too soon
.S Y=$P(^PSRX(R,0),U,8) ;DAYS SUPPLY
.S F=$P(^PSRX(R,0),U,9) ;# REFILLS
.S T=Y*(F+1) ;total days supply
.S I=$P(^PSRX(R,0),U,13) ;ISSUE DATE
.Q:I>ED ;issued after audit year
.Q:$$FMADD^XLFDT(I,T)<BDMD ;days supply doesn't get to date
.S G="X"
I G]"" Q G
;NOW CHECK FOR E H R OUTSIDE MED IN V MED IN PAST 10 YEARS
EHROUT ;
;any EHR outside meds?
K BDMMEDS1 S K=0,R=""
S X=P_"^ALL MEDS ["_$P(^ATXAX(TAX,0),U,1)_";DURING "_$$FMADD^XLFDT(ED,-3650)_"-"_ED S E=$$START1^APCLDF(X,"BDMMEDS1(")
I '$D(BDMMEDS1) Q ""
S X=0 F S X=$O(BDMMEDS1(X)) Q:X'=+X!(R]"") S Y=+$P(BDMMEDS1(X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.Q:$P($G(^AUPNVMED(Y,11)),U,8)="" ;NOT AN EHR OUTSIDE MED
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S %=$P(^AUPNVMED(Y,0),U,8) ;discontinued date
.I %]"",%<$$FMADD^XLFDT($$FMADD^XLFDT(ED,-186)) Q ;if discontinued before 6M of report period
.S V=$P(^AUPNVMED(Y,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S R="X" ;1_U_"Statin: "_$$DATE^BGP8UTL($P($P(^AUPNVSIT(V,0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,Y,.01)_" (EHR OUTSIDE)"
Q R
PRESD(P,TAX,ED,DAYS) ;EP
;GO THROUGH 52 FOR PATIENT
NEW BDMD,G,Z,R,D,E,T,F,I
S BDMD=$$FMADD^XLFDT(ED,-DAYS) ;DATE OF EXPIRATION NEEDS TO BE GREATER THAN THIS AND DAYS SUPPLY * REFILLS NEEDS TO BE GREATER THAN THIS ADDED TO ISSUE DATE
S Z=0,G="" F S Z=$O(^PS(55,P,"P",Z)) Q:Z'=+Z!(G) D
.S R=$P(^PS(55,P,"P",Z,0),U,1)
.Q:'$D(^PSRX(R,0)) ;bad xref
.Q:$E($P(^PSRX(R,0),U,1))'="X" ;not an external med
.S D=$P(^PSRX(R,0),U,6)
.Q:'D ;no drug??
.Q:'$D(^ATXAX(TAX,21,"B",D)) ;not a drug we care about
.S E=$P($G(^PSRX(R,2)),U,6)
.I E,E<BDMD Q ;expires too soon
.S Y=$P(^PSRX(R,0),U,8) ;DAYS SUPPLY
.S F=$P(^PSRX(R,0),U,9) ;# REFILLS
.S T=Y*(F+1) ;total days supply
.S I=$P(^PSRX(R,0),U,13) ;ISSUE DATE
.Q:I>ED
.Q:$$FMADD^XLFDT(I,T)<BDMD ;days supply doesn't get to date
.S G="1 Yes "_$$DATE^BDMS9B1(I)_" "_$E($P(^PSDRUG(D,0),U,1),1,30)_"("_T_" days supply)"
I $E(G)=1 Q G
EHROUTD ;
;any EHR outside meds?
K BDMMEDS1 S K=0,R=""
S X=P_"^ALL MEDS ["_$P(^ATXAX(TAX,0),U,1)_";DURING "_$$FMADD^XLFDT(ED,-3650)_"-"_ED S E=$$START1^APCLDF(X,"BDMMEDS1(")
I '$D(BDMMEDS1) Q ""
S X=0 F S X=$O(BDMMEDS1(X)) Q:X'=+X!(R]"") S Y=+$P(BDMMEDS1(X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.Q:$P($G(^AUPNVMED(Y,11)),U,8)="" ;NOT AN EHR OUTSIDE MED
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S %=$P(^AUPNVMED(Y,0),U,8) ;discontinued date
.I %]"",%<$$FMADD^XLFDT($$FMADD^XLFDT(ED,-186)) Q ;if discontinued before 6M of report period
.S V=$P(^AUPNVMED(Y,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S D=$P(^AUPNVMED(Y,0),U,1)
.S R="1 Yes "_$$DATE^BDMS9B1($$VD^APCLV(V))_" "_$E($P(^PSDRUG(D,0),U,1),1,30)_" (EHR OUTSIDE)"
Q R
BDMDG18 ; IHS/CMI/LAB - 2019 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
+2 ;
+3 ;
HT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,BDMARRY,H,E,D,W
+3 SET E=$ORDER(^AUTTMSR("B","HT",0))
+4 SET H=""
+5 SET D=0
FOR
SET D=$ORDER(^AUPNVMSR("AA",P,E,D))
IF D'=+D!(H]"")
QUIT
Begin DoDot:1
+6 SET W=0
FOR
SET W=$ORDER(^AUPNVMSR("AA",P,E,D,W))
IF W'=+W!(H]"")
QUIT
Begin DoDot:2
+7 IF '$DATA(^AUPNVMSR(W,0))
QUIT
+8 ;entered in error
IF $PIECE($GET(^AUPNVMSR(W,2)),U,1)
QUIT
+9 SET H=$PIECE(^AUPNVMSR(W,0),U,4)
+10 SET BDMARRAY(1)=$$VD^APCLV($PIECE(^AUPNVMSR(W,0),U,3))
End DoDot:2
End DoDot:1
+11 IF H=""
QUIT H
+12 IF H["?"
QUIT ""
+13 SET H=$JUSTIFY(H,5,2)
+14 QUIT $$STRIP^XLFSTR(H," ")
+15 ;
WT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD,BDMVF
+3 KILL BDM
SET BDMW=""
SET BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(BDMX,"BDM(")
+4 SET BDMN=0
FOR
SET BDMN=$ORDER(BDM(BDMN))
IF BDMN'=+BDMN!(BDMW]"")
QUIT
Begin DoDot:1
+5 SET BDMVF=+$PIECE(BDM(BDMN),U,4)
+6 ;entered in error
IF $PIECE($GET(^AUPNVMSR(BDMVF,2)),U,1)
QUIT
+7 SET BDMZ=$PIECE(BDM(BDMN),U,5)
+8 IF '$DATA(^AUPNVPOV("AD",BDMZ))
SET BDMW=$PIECE(BDM(BDMN),U,2)
QUIT
+9 SET BDMD=0
SET G=0
FOR
SET BDMD=$ORDER(^AUPNVPOV("AD",BDMZ,BDMD))
IF 'BDMD!(G=1)
QUIT
Begin DoDot:2
+10 ;cmi/anch/maw 9/12/2007 csv
SET ICD=$$VALI^XBDIQ1(9000010.07,BDMD,.01)
Begin DoDot:3
+11 ;cmi/maw 05/15/2014 p8
IF $$ICD^BDMUTL(ICD,"BGP PREGNANCY DIAGNOSES 2",9)
SET G=1
End DoDot:3
End DoDot:2
+12 IF 'G
SET BDMW=$PIECE(BDM(BDMN),U,2)
End DoDot:1
+13 QUIT BDMW
BMI(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,W,H,B,D,%DT,X
+3 SET %=""
+4 Begin DoDot:1
+5 ;S W=W+.5,W=$P(W,".")
SET W=$$WT(P,BDATE,EDATE)
IF W=""
QUIT
SET W=W\1
+6 SET HDATE=$PIECE(^DPT(P,0),U,3)
+7 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+8 ;S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
+9 SET H=H*H
SET %=(W/H)*703
SET %=$JUSTIFY(%,5,1)
+10 QUIT
End DoDot:1
QUIT %
+11 QUIT
CREAT(P,BDATE,EDATE,F) ;EP
+1 GOTO CREAT^BDMDG1C
CHOL(P,BDATE,EDATE,F) ;EP
+1 GOTO CHOL^BDMDG1C
HDL(P,BDATE,EDATE,F) ;EP
+1 GOTO HDL^BDMDG1C
LDL(P,BDATE,EDATE,F) ;EP
+1 GOTO LDL^BDMDG1C
TRIG(P,BDATE,EDATE,F) ;EP
+1 GOTO TRIG^BDMDG1C
URIN(P,BDATE,EDATE) ;EP
+1 GOTO URIN^BDMDG1H
PROTEIN(P,BDATE,EDATE) ;EP
+1 GOTO PROTEIN^BDMDG1C
MICRO(P,BDATE,EDATE) ;EP
+1 GOTO MICRO^BDMDG1C
HGBA1C(P,BDATE,EDATE) ;EP
+1 GOTO HGBA1C^BDMDG1D
SEMI(P,BDATE,EDATE) ;EP
+1 GOTO SEMI^BDMDG1C
PPDS(P) ;
+1 NEW BDMS,E,X
+2 KILL BDMS
+3 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"BDMS(")
+4 IF $DATA(BDMS)
QUIT 1_U_$$DATE^BDMS9B1($PIECE(BDMS(1),U))_" HF: "_$PIECE(BDMS(1),U,3)
PPDSPL ;CHECK PL
+1 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT TUBERCULOSIS DXS",0))
+2 IF 'T
QUIT ""
+3 ;N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=X
+4 ;cmi/maw 05/15/2014 p8
NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^BDMUTL(Y,$PIECE(^ATXAX(T,0),U),9)
SET I=X
+5 IF I
QUIT 1_U_$$DATE^BDMS9B1($$VALI^XBDIQ1(9000011,I,.03))_" Problem List: "_$$VAL^XBDIQ1(9000011,I,.01)
+6 ;check povs
+7 KILL BDMS
SET X=P_"^FIRST DX [DM AUDIT TUBERCULOSIS DXS"
SET E=$$START1^APCLDF(X,"BDMS(")
+8 IF $DATA(BDMS(1))
QUIT 1_U_$$DATE^BDMS9B1($PIECE(BDMS(1),U))_" POV: "_$PIECE(BDMS(1),U,3)
+9 QUIT ""
PPD(P,EDATE,F) ;EP
+1 ;f 1=tb test done
+2 ;f 2=tb result
+3 SET F=$GET(F)
+4 ;RETURN 1^1 Skin Test||1 Positive
+5 NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED,LD,LR
+6 SET LD=""
SET LR=""
+7 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+8 ;IF HAD HF or dx or pl of TB use it as positive
SET G=$$PPDS(P)
IF G
QUIT "1 TB Positive "_$PIECE(G,U,2)_"||1 Positive TB "_$PIECE(G,U,2)
+9 KILL BDM
+10 ;get, in reverse order all skin tests and lab tests for TB testing (BDM(inverse date,#)=ST or LAB^ien^result^reading
+11 SET X=$ORDER(^AUTTSK("B","PPD",0))
+12 SET D=9999999-ED-1
SET C=0
FOR
SET D=$ORDER(^AUPNVSK("AA",P,X,D))
IF D=""
QUIT
Begin DoDot:1
+13 SET G=0
FOR
SET G=$ORDER(^AUPNVSK("AA",P,X,D,G))
IF G'=+G
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVSK(G,0))
QUIT
+15 SET C=C+1
SET BDM(D,C)="ST"_U_G_U_$PIECE(^AUPNVSK(G,0),U,5)_U_$SELECT($PIECE(^AUPNVSK(G,0),U,4)="D":"",$PIECE(^AUPNVSK(G,0),U,4)="O":"",1:$PIECE(^AUPNVSK(G,0),U,4))
End DoDot:2
End DoDot:1
+16 SET BDMC=0
+17 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT TB LAB TESTS",0))
+18 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT TB TEST LOINC",0))
+19 SET G=""
SET E=9999999-ED
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+20 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+22 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+23 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+24 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+25 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+26 SET C=C+1
SET BDM(D,C)="LAB^"_X_U_$PIECE(^AUPNVLAB(X,0),U,4)
SET G=1
End DoDot:4
+27 IF 'BDMOT
QUIT
+28 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+29 IF '$$LOINC^BDMDG1C(J,BDMOT)
QUIT
+30 SET C=C+1
SET BDM(D,C)="LAB^"_X_U_$PIECE(^AUPNVLAB(X,0),U,4)
SET G=1
+31 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;now get latest with a result and use it, if none with a result take latest one
+33 ;if none, quit on value
+34 SET (D,C)=0
SET G=""
+35 FOR
SET D=$ORDER(BDM(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+36 SET C=0
FOR
SET C=$ORDER(BDM(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+37 IF $PIECE(BDM(D,C),U,3)]""!($PIECE(BDM(D,C),U,4)]"")
SET G=BDM(D,C)
End DoDot:2
End DoDot:1
+38 IF F="I"
QUIT $SELECT($PIECE(G,U,1)="LAB":$$VD^APCLV($PIECE(^AUPNVLAB($PIECE(G,U,2),0),U,3)),1:$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3)))
+39 ;C=1 skin test||result value
IF G]""
SET C=""
Begin DoDot:1
+40 SET C=$SELECT($PIECE(G,U,1)="ST":"1 Skin test (PPD)",1:"2 Blood Test (QFT-G, T SPOT-TB)")
+41 ;GET RESULT VALUE
+42 IF $PIECE(G,U,1)="LAB"
SET R=$PIECE(G,U,3)
Begin DoDot:2
+43 IF $EXTRACT($$UP^XLFSTR(R))="P"
SET C=C_"||1 Positive "_$$VD^APCLV($PIECE(^AUPNVLAB($PIECE(G,U,2),0),U,3),"S")_" lab result: "_R
QUIT
+44 IF $EXTRACT($$UP^XLFSTR(R))="N"
SET C=C_"||2 Negative "_$$VD^APCLV($PIECE(^AUPNVLAB($PIECE(G,U,2),0),U,3),"S")_" lab result: "_R
QUIT
+45 SET C=C_"||3 Unknown"
QUIT
End DoDot:2
QUIT
+46 IF $PIECE(G,U,1)="ST"
Begin DoDot:2
+47 SET R=$PIECE(G,U,3)
SET R1=$PIECE(G,U,4)
+48 IF R]""
IF R>9
SET C=C_"||1 Positive "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
+49 IF R]""
IF R<10
SET C=C_"||2 Negative "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
+50 IF R1]""
IF R1="P"
SET C=C_"||1 Positive "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
+51 IF R1]""
IF R1="N"
SET C=C_"||2 Negative "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
+52 ;S C=C_"||3 Unknown" Q
End DoDot:2
QUIT
End DoDot:1
QUIT C
+53 QUIT "3 Unknown||"
+54 ;
LASTNP(P,EDATE) ;EP - last negative ppd
+1 IF $EXTRACT($PIECE($$PPD(P,EDATE),"||",2))'="2"
QUIT ""
+2 QUIT $$PPD(P,EDATE,"I")
+3 ;
FGLUCOSE(P,BDATE,EDATE,F) ;EP
+1 GOTO FGLUCOSE^BDMDG1D
G75(P,BDATE,EDATE,F) ;EP
+1 GOTO G75^BDMDG1D
+2 ;
STV(X,T,D) ;EP - strip hgba1c before epi export
+1 ;no value in X so don't bother
IF X=""
QUIT X
+2 IF X="?"
QUIT ""
+3 NEW A,B,L
+4 SET L=$LENGTH(X)
+5 IF $EXTRACT(X)?1N
SET X=+X
+6 FOR B=1:1:L
SET A=$EXTRACT(X,B)
IF A=""
QUIT
IF A'?1N
IF A'?1"."
SET X=$$STRIP^XLFSTR(X,A)
SET B=B-1
+7 IF X=""
QUIT ""
+8 IF $GET(D)
IF X["."
SET X=$JUSTIFY(X,T,D)
+9 SET X=$$STRIP^XLFSTR(X," ")
+10 QUIT $EXTRACT(X,1,T)
STE(X,T,D) ;EP - strip hgba1c before epi export
+1 ;no value in X so don't bother
IF X=""
QUIT X
+2 IF X="?"
QUIT ""
+3 NEW A,B,L
+4 SET L=$LENGTH(X)
+5 FOR B=1:1:L
SET A=$EXTRACT(X,B)
IF A=""
QUIT
IF A'?1N
IF A'?1"."
IF X'?1"+"
IF X'?1"-"
IF X'?1">"
IF X'?1"<"
SET X=$$STRIP^XLFSTR(X,A)
SET B=B-1
+6 IF X=""
QUIT ""
+7 IF $GET(D)
IF X["."
SET X=$JUSTIFY(X,T,D)
+8 SET X=$$STRIP^XLFSTR(X," ")
+9 QUIT $EXTRACT(X,1,T)
AS(X) ;EP
+1 IF $EXTRACT(X)="<"
SET X=$EXTRACT(X,2,99)
SET X=X-1
QUIT X
+2 IF $EXTRACT(X)=">"
SET X=$EXTRACT(X,2,99)
SET X=X+1
QUIT X
+3 QUIT X
+4 ;
GFRDES(P,BDATE,EDATE,EEGFR) ;EP
+1 NEW A,B,C
+2 SET A=$$CALCGFR(P,BDATE,EDATE)
+3 IF A=""
QUIT 0
+4 SET A=$PIECE(A,U,2)
+5 IF $EXTRACT(A)=">"
SET C=0
Begin DoDot:1
+6 SET A=60
+7 IF EEGFR>60
SET C=0
QUIT
+8 IF EEGFR<50
SET C=1
QUIT
End DoDot:1
QUIT C
+9 SET A=$$STV^BDMDG18(A,5,1)
+10 SET B=EEGFR-A
+11 IF B>10
QUIT 1
+12 IF B<-10
QUIT 1
+13 QUIT 0
CALCGFRZ(P,BDATE,EDATE) ;EP
+1 NEW R,C,X,Y,Z,D
+2 SET R=$$CREAT^BDMDG18(P,BDATE,EDATE,"I")
SET D=$PIECE(R,U,2)
SET R=$PIECE(R,U,1)
+3 IF R=""
QUIT ""
+4 ;CALCULATE IT
+5 SET BDMSEX=$PIECE(^DPT(P,0),U,2)
+6 SET BDMAGE=$$AGE^AUPNPAT(P,D)
+7 SET X=$$GFRSE1CZ(P,R,BDMAGE,BDMSEX)
+8 QUIT D_U_X_"^ESTIMATED GFR (CALC)"
GFRSE1CZ(DFN,CRET,BDMAGE,BDMSEX) ; EP
+1 ;D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("GFRSE1CU^BLREXEC2")
+2 ;
+3 ; Check for Errors
SET %X=$$CHKERRS
+4 ; If NOT OK, quit with error
IF %X'="OK"
QUIT %X
+5 ;
+6 NEW CONSTA,CRETEXP,AGEEXP,SEXFACTR,RACEFACT
+7 ; Setup constants & exponents
DO SETVARS1
+8 ;
+9 SET %X=CONSTA*(CRET**CRETEXP)*(BDMAGE**AGEEXP)*$GET(SEXFACTR)*$GET(RACEFACT)
+10 ;
+11 ;ROUND RESULT
SET %X=$TRANSLATE($FNUMBER(%X,"",0)," ")
+12 ;
+13 ; See www.nkdep.nih.gov/resources/laboratory_reporting.htm
+14 ;I %X>60 S %X=">60"
+15 ;
+16 QUIT %X
CALCGFR(P,BDATE,EDATE) ;EP
+1 NEW R,C,X,Y,Z,D
+2 SET R=$$CREAT^BDMDG18(P,BDATE,EDATE,"I")
SET D=$PIECE(R,U,2)
SET R=$PIECE(R,U,1)
+3 IF R=""
QUIT ""
+4 ;CALCULATE IT
+5 SET BDMSEX=$PIECE(^DPT(P,0),U,2)
+6 SET BDMAGE=$$AGE^AUPNPAT(P,D)
+7 SET X=$$GFRSE1CU(P,R,BDMAGE,BDMSEX)
+8 QUIT D_U_X_"^ESTIMATED GFR (CALC)"
GFRSE1CU(DFN,CRET,BDMAGE,BDMSEX) ; EP
+1 ;D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("GFRSE1CU^BLREXEC2")
+2 ;
+3 ; Check for Errors
SET %X=$$CHKERRS
+4 ; If NOT OK, quit with error
IF %X'="OK"
QUIT %X
+5 ;
+6 NEW CONSTA,CRETEXP,AGEEXP,SEXFACTR,RACEFACT
+7 ; Setup constants & exponents
DO SETVARS1
+8 ;
+9 SET %X=CONSTA*(CRET**CRETEXP)*(BDMAGE**AGEEXP)*$GET(SEXFACTR)*$GET(RACEFACT)
+10 ;
+11 ;ROUND RESULT
SET %X=$TRANSLATE($FNUMBER(%X,"",0)," ")
+12 ;
+13 ; See www.nkdep.nih.gov/resources/laboratory_reporting.htm
+14 IF %X>60
SET %X=">60"
+15 ;
+16 QUIT %X
+17 ;
CHKERRS() ; EP
+1 NEW BDMERR
+2 SET BDMERR="N/A"
+3 ;
+4 ; If creatinine null, then quit
IF $TRANSLATE($GET(CRET)," ")=""
QUIT BDMERR
+5 ;
+6 ; If 1st character not numeric, then quit
+7 ; I $E($G(CRET))'?1N Q BDMERR
+8 ; IHS/OIT/MKK - LR*5.2*1026
IF $GET(CRET)?1A.A
SET %X=BDMERR
QUIT %X
+9 ;
+10 ; Following lines added to handle errors sent by some instruments
+11 ; Quit if any are true
+12 ; If Null
IF $EXTRACT($GET(CRET))=""
QUIT BDMERR
+13 ; Out of Range
IF $EXTRACT($GET(CRET))="#"
QUIT BDMERR
+14 ; Vitros results with "<"
IF $EXTRACT($GET(CRET))="<"
QUIT BDMERR
+15 ; Negative results
IF ($GET(CRET))="-"
QUIT BDMERR
+16 ;
+17 ; If zero results, then quit
IF +$GET(CRET)=0
QUIT BDMERR
+18 ;
+19 ;I AGE["DYS"!(AGE["MOS")!(AGE<17) Q BDMERR ; 16 & younger not done, quit
+20 IF BDMAGE<18
QUIT BDMERR
+21 ;
+22 ; Cannot calculate without SEX
IF BDMSEX=""
QUIT BDMERR
+23 IF BDMSEX="U"
QUIT BDMERR
+24 ;
+25 QUIT "OK"
+26 ;
SETVARS1 ; EP
+1 ;CONSTANTS, EXPONENTS
+2 ; Sex Factor
SET SEXFACTR=$SELECT(BDMSEX="M":1,1:.742)
+3 ;
+4 SET RACEFACT=$SELECT($$RACE(DFN)="B":1.21,1:1)
+5 ;
+6 ; CONSTANT A
SET CONSTA=186
+7 ; CREATININE EXPONENT
SET CRETEXP=-1.154
+8 ; AGE EXPONENT
SET AGEEXP=-.203
+9 ;
+10 ;D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("SETVARS1^BLREXEC2")
+11 QUIT
RACE(DFN) ; EP
+1 NEW RACEPTR,RACEENT,V
+2 ;
+3 IF $TEXT(RACE^AGUTL)]""
Begin DoDot:1
+4 SET V=""
+5 SET RACEPTR=$$RACE^AGUTL(DFN)
+6 IF $PIECE(RACEPTR,U)=1
IF $PIECE(RACEPTR,U,2)["BLACK"
SET V="B"
+7 SET V="N"
End DoDot:1
QUIT V
+8 SET RACEPTR=$PIECE($GET(^DPT(+$GET(DFN),0)),U,6)
+9 ; If no entry, consider non-black
IF RACEPTR=""
QUIT "N"
+10 ;
+11 SET RACEENT=$PIECE($GET(^DIC(10,RACEPTR,0)),U)
+12 ; If RACEENT contains BLACK >= race = Black
IF RACEENT[("BLACK")
QUIT "B"
+13 ; otherwise, non-black
QUIT "N"
+14 ;
PRES(P,TAX,ED) ;EP
+1 ;GO THROUGH 52 FOR PATIENT
+2 NEW BDMD,G,Z,R,D,E,T,F,I,BDMMEDS1,Y,%,K,V
+3 ;DATE OF EXPIRATION NEEDS TO BE GREATER THAN THIS AND DAYS SUPPLY * REFILLS NEEDS TO BE GREATER THAN THIS ADDED TO ISSUE DATE
SET BDMD=$$FMADD^XLFDT(ED,-(6*31))
+4 SET Z=0
SET G=""
FOR
SET Z=$ORDER(^PS(55,P,"P",Z))
IF Z'=+Z!(G="X")
QUIT
Begin DoDot:1
+5 SET R=$PIECE(^PS(55,P,"P",Z,0),U,1)
+6 ;bad xref
IF '$DATA(^PSRX(R,0))
QUIT
+7 ;not an external med
IF $EXTRACT($PIECE(^PSRX(R,0),U,1))'="X"
QUIT
+8 SET D=$PIECE(^PSRX(R,0),U,6)
+9 ;no drug??
IF 'D
QUIT
+10 ;not a drug we care about
IF '$DATA(^ATXAX(TAX,21,"B",D))
QUIT
+11 SET E=$PIECE($GET(^PSRX(R,2)),U,6)
+12 ;expires too soon
IF E
IF E<BDMD
QUIT
+13 ;DAYS SUPPLY
SET Y=$PIECE(^PSRX(R,0),U,8)
+14 ;# REFILLS
SET F=$PIECE(^PSRX(R,0),U,9)
+15 ;total days supply
SET T=Y*(F+1)
+16 ;ISSUE DATE
SET I=$PIECE(^PSRX(R,0),U,13)
+17 ;issued after audit year
IF I>ED
QUIT
+18 ;days supply doesn't get to date
IF $$FMADD^XLFDT(I,T)<BDMD
QUIT
+19 SET G="X"
End DoDot:1
+20 IF G]""
QUIT G
+21 ;NOW CHECK FOR E H R OUTSIDE MED IN V MED IN PAST 10 YEARS
EHROUT ;
+1 ;any EHR outside meds?
+2 KILL BDMMEDS1
SET K=0
SET R=""
+3 SET X=P_"^ALL MEDS ["_$PIECE(^ATXAX(TAX,0),U,1)_";DURING "_$$FMADD^XLFDT(ED,-3650)_"-"_ED
SET E=$$START1^APCLDF(X,"BDMMEDS1(")
+4 IF '$DATA(BDMMEDS1)
QUIT ""
+5 SET X=0
FOR
SET X=$ORDER(BDMMEDS1(X))
IF X'=+X!(R]"")
QUIT
SET Y=+$PIECE(BDMMEDS1(X),U,4)
Begin DoDot:1
+6 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+7 ;NOT AN EHR OUTSIDE MED
IF $PIECE($GET(^AUPNVMED(Y,11)),U,8)=""
QUIT
+8 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+9 ;discontinued date
SET %=$PIECE(^AUPNVMED(Y,0),U,8)
+10 ;if discontinued before 6M of report period
IF %]""
IF %<$$FMADD^XLFDT($$FMADD^XLFDT(ED,-186))
QUIT
+11 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+12 IF 'V
QUIT
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 ;1_U_"Statin: "_$$DATE^BGP8UTL($P($P(^AUPNVSIT(V,0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,Y,.01)_" (EHR OUTSIDE)"
SET R="X"
End DoDot:1
+15 QUIT R
PRESD(P,TAX,ED,DAYS) ;EP
+1 ;GO THROUGH 52 FOR PATIENT
+2 NEW BDMD,G,Z,R,D,E,T,F,I
+3 ;DATE OF EXPIRATION NEEDS TO BE GREATER THAN THIS AND DAYS SUPPLY * REFILLS NEEDS TO BE GREATER THAN THIS ADDED TO ISSUE DATE
SET BDMD=$$FMADD^XLFDT(ED,-DAYS)
+4 SET Z=0
SET G=""
FOR
SET Z=$ORDER(^PS(55,P,"P",Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:1
+5 SET R=$PIECE(^PS(55,P,"P",Z,0),U,1)
+6 ;bad xref
IF '$DATA(^PSRX(R,0))
QUIT
+7 ;not an external med
IF $EXTRACT($PIECE(^PSRX(R,0),U,1))'="X"
QUIT
+8 SET D=$PIECE(^PSRX(R,0),U,6)
+9 ;no drug??
IF 'D
QUIT
+10 ;not a drug we care about
IF '$DATA(^ATXAX(TAX,21,"B",D))
QUIT
+11 SET E=$PIECE($GET(^PSRX(R,2)),U,6)
+12 ;expires too soon
IF E
IF E<BDMD
QUIT
+13 ;DAYS SUPPLY
SET Y=$PIECE(^PSRX(R,0),U,8)
+14 ;# REFILLS
SET F=$PIECE(^PSRX(R,0),U,9)
+15 ;total days supply
SET T=Y*(F+1)
+16 ;ISSUE DATE
SET I=$PIECE(^PSRX(R,0),U,13)
+17 IF I>ED
QUIT
+18 ;days supply doesn't get to date
IF $$FMADD^XLFDT(I,T)<BDMD
QUIT
+19 SET G="1 Yes "_$$DATE^BDMS9B1(I)_" "_$EXTRACT($PIECE(^PSDRUG(D,0),U,1),1,30)_"("_T_" days supply)"
End DoDot:1
+20 IF $EXTRACT(G)=1
QUIT G
EHROUTD ;
+1 ;any EHR outside meds?
+2 KILL BDMMEDS1
SET K=0
SET R=""
+3 SET X=P_"^ALL MEDS ["_$PIECE(^ATXAX(TAX,0),U,1)_";DURING "_$$FMADD^XLFDT(ED,-3650)_"-"_ED
SET E=$$START1^APCLDF(X,"BDMMEDS1(")
+4 IF '$DATA(BDMMEDS1)
QUIT ""
+5 SET X=0
FOR
SET X=$ORDER(BDMMEDS1(X))
IF X'=+X!(R]"")
QUIT
SET Y=+$PIECE(BDMMEDS1(X),U,4)
Begin DoDot:1
+6 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+7 ;NOT AN EHR OUTSIDE MED
IF $PIECE($GET(^AUPNVMED(Y,11)),U,8)=""
QUIT
+8 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+9 ;discontinued date
SET %=$PIECE(^AUPNVMED(Y,0),U,8)
+10 ;if discontinued before 6M of report period
IF %]""
IF %<$$FMADD^XLFDT($$FMADD^XLFDT(ED,-186))
QUIT
+11 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+12 IF 'V
QUIT
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+15 SET R="1 Yes "_$$DATE^BDMS9B1($$VD^APCLV(V))_" "_$EXTRACT($PIECE(^PSDRUG(D,0),U,1),1,30)_" (EHR OUTSIDE)"
End DoDot:1
+16 QUIT R
