BDWUTIL1 ; IHS/CMI/LAB - Data Warehouse Utilities ;
;;1.0;IHS DATA WAREHOUSE;**1,2,4**;JAN 23, 2006;Build 24
;
;
;
ORF(P) ;EP patient has ORF?
I '$G(P) Q 0
NEW FLAG,D
S FLAG=0
;
S D=0
F S D=$O(^AUPNPAT(P,41,D)) Q:+D=0 D
. Q:$P($G(^AGFAC(D,0)),"^",21)'="Y" ;only want ORFs
. S FLAG=1 ;found one
. Q
Q FLAG
CHART(V) ;PEP - returns ASUFAC_HRN ( 12 digits, HRN is left zero filled)
;V = visit ien, returns asufac_hrn for this visit
NEW L,%,C,S,P,Z
S %=""
I V="" Q $$CHARTREG^BDWUTIL1(DFN) ;p4
I '$D(^AUPNVSIT(V,0)) Q % ;bogus visit
S Z=^AUPNVSIT(V,0)
S P=$P(Z,U,5) ;get patient pointer
I 'P Q % ;no patient so quit
S L=$P(Z,U,6) ;location of encounter of visit
I 'L Q "" ;if no loc then quit, shouldn't happen
I $D(^AUPNPAT(P,41,L,0)) S %=$$GETCHART(P,L) I %]"" Q % ;get hrn at loc of enc if have one use it
S L=$P($G(^AUTTSITE(1,0)),U) S %=$$GETCHART(P,L) I %]"" Q % ;get hrn at rpms site, if have one use it
I $G(DUZ(2)) S L=DUZ(2) S %=$$GETCHART(P,L) I %]"" Q % ;get hrn at logged in site, if have one use it
S L=0 F S L=$O(^AUPNPAT(P,41,L)) Q:L'=+L!(%]"") S %=$$GETCHART(P,L) ;get first one in multiple that is an official reg fac
Q %
GETCHART(P,L) ;
NEW R,S
S R=""
I $P($G(^AGFAC(L,0)),U,21)'="Y" Q "" ;not an official reg fac so quit, must be an orf
S S=$P(^AUTTLOC(L,0),U,10) ;get asufac for this location
I S="" Q ""
S C=$P($G(^AUPNPAT(P,41,L,0)),U,2) ;get hrn for this location
I C="" Q ""
S R=S_C ;return asufac_hrn
Q R
;
CHARTREG(P) ;EP
I '$G(P) Q ""
I '$D(^AUPNPAT(P)) Q ""
NEW L,%,C,S
S %=""
S L=$P($G(^AUTTSITE(1,0)),U) S %=$$GETCHART(P,L) I %]"" Q % ;get hrn at rpms site, if have one use it
I $G(DUZ(2)) S L=DUZ(2) S %=$$GETCHART(P,L) I %]"" Q % ;get hrn at logged in site, if have one use it
S L=0 F S L=$O(^AUPNPAT(P,41,L)) Q:L'=+L!(%]"") S %=$$GETCHART(P,L) ;get first one in multiple that is an official reg fac
Q %
HDL(V) ;
Q $$LABDONE^BDWUTIL(V,"DM AUDIT HDL TAX")
HDLVALUE(V) ;
Q $$LABRES^BDWUTIL(V,"DM AUDIT HDL TAX")
;
LDL(V) ;
Q $$LABDONE^BDWUTIL(V,"DM AUDIT LDL CHOLESTEROL TAX")
;
LDLVALUE(V) ;
Q $$LABRES^BDWUTIL(V,"DM AUDIT LDL CHOLESTEROL TAX")
;
TRI(V) ;
Q $$LABDONE^BDWUTIL(V,"DM AUDIT TRIGLYCERIDE TAX")
;
TRIVALUE(V) ;
Q $$LABRES^BDWUTIL(V,"DM AUDIT TRIGLYCERIDE TAX")
;
PSA(V) ;
Q $$LABDONE^BDWUTIL(V,"BDW PSA TESTS TAX")
;
FECAL(V) ;
Q $$LABDONE^BDWUTIL(V,"APCH FECAL OCCULT BLOOD")
;
NLAB(V) ;
NEW X,Y
S (X,Y)=0 F S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X S Y=Y+1
Q Y
CHSPO(V) ;EP return vendor type from VCHS
I '$G(V) Q ""
I '$D(^AUPNVSIT(V)) Q ""
NEW C S C=$O(^AUPNVCHS("AD",V,0))
I 'C Q ""
I '$D(^AUPNVCHS(C,0)) Q ""
NEW A
S A=$P(^AUPNVCHS(C,0),U)
S A=$P($G(^AUTTLOC(A,0)),U,10)
Q $P(^AUPNVCHS(C,0),U,4)_"^"_A
ST(RETVAL,BDWV) ;EP -
K RETVAL
I '$G(BDWV) Q
I '$D(^AUPNVSIT(BDWV)) Q
NEW BDWI,BDWC,BDWE
S (BDWI,BDWC)=0
F S BDWI=$O(^AUPNVSK("AD",BDWV,BDWI)) Q:BDWI'=+BDWI D
.Q:'$D(^AUPNVSK(BDWI,0))
.S BDWE=$P(^AUPNVSK(BDWI,0),"^")
.I '$D(^AUTTSK(BDWE,0)) Q
.S BDWE=$P(^AUTTSK(BDWE,0),"^",2)
.S BDWC=BDWC+1,RETVAL(BDWC)=BDWE_"^"_$P(^AUPNVSK(BDWI,0),"^",4)_"^"_$P(^AUPNVSK(BDWI,0),"^",5)
.Q
Q
;
IFC(RETVAL,BDWV) ;EP -
K RETVAL
I '$G(BDWV) Q
I '$D(^AUPNVSIT(BDWV)) Q
NEW BDWI,BDWC,BDWE,BDWIE
S (BDWI,BDWC)=0
F S BDWI=$O(^AUPNVIF("AD",BDWV,BDWI)) Q:BDWI'=+BDWI D
.Q:'$D(^AUPNVIF(BDWI,0))
.S BDWIE=$$GET1^DIQ(9000010.44,BDWI,.01,"I")
.S BDWE=$$GET1^DIQ(9000010.44,BDWI,.01)
.S BDWC=BDWC+1,RETVAL(BDWC)=BDWIE_"^"_BDWE
.Q
Q
;
PROV(RETVAL,BDWV) ;EP
NEW BDWP,BDWS,BDWC,BDWPIEN,BDWCS,BDWAD,X,Y,G,D
K RETVAL
I '$D(^AUPNVPRV("AD",BDWV)) Q
S BDWP="",BDWCS=1
F S BDWP=$O(^AUPNVPRV("AD",BDWV,BDWP)) Q:BDWP'=+BDWP D
.Q:'$D(^AUPNVPRV(BDWP,0))
.I $P(^AUPNVPRV(BDWP,0),"^",4)="P" S BDWC=1
.I $P(^AUPNVPRV(BDWP,0),"^",4)'="P" S BDWCS=BDWCS+1,BDWC=BDWCS
.S BDWPIEN=$P(^AUPNVPRV(BDWP,0),"^")
.S BDWAD=$$O(BDWPIEN)
.S RETVAL(BDWC)=$P(^AUPNVPRV(BDWP,0),"^")_"^"_$S($P(^DD(9000010.06,.01,0),"^",2)[200:200,1:6)_"^"_BDWAD_"^"_$$C(BDWPIEN)_"^"_$S($E(BDWAD,2,3)=17:1,1:"")
.;6th is classification
.;7th is specialty
.;8th is type
.S Y=BDWPIEN ;ien in file 200 should be in Y
.I $P(^DD(9000010.06,.01,0),U,2)[6 S Y=$G(^DIC(16,BDWPIEN,"A3"))
.I Y="" Q
.;get USC1 node value
.S D=$P(^AUPNVPRV(BDWP,0),"^",3) Q:D=""
.S D=$P($G(^AUPNVSIT(D,0)),"^"),D=$P(D,".",1)
.I D="" Q
.S G=$$PCC(Y,D)
.S $P(RETVAL(BDWC),"^",6)=G
.Q
Q
PCC(P,D) ;EP - RETURN CLASS^SPEC^TYPE for provider P on date D
I $G(P)="" Q ""
I $G(D)="" Q ""
I '$D(^VA(200,P,0)) Q ""
I '$O(^VA(200,P,"USC1",0)) Q ""
NEW X,Y,Z
S (X,Z)=0 F S X=$O(^VA(200,P,"USC1",X)) Q:X'=+X!(Z) D
.S Y=$G(^VA(200,P,"USC1",0))
.I $P(Y,U,2)]"",$P(Y,U,3)]"",D'<$P(Y,U,2),D'>$P(Y,U,3) S Z=X Q ;both dates and a match
.I $P(Y,U,2)]"",$P(Y,U,3)="",D'<$P(Y,U,2) S Z=X Q ;beg date, no expire visit after beg
.Q
I 'Z S Z=$O(^VA(200,P,"USC1",0))
S Z=$P(^VA(200,P,"USC1",Z,0),U)
I 'Z Q ""
I '$D(^USC(8932.1,Z,0)) Q ""
S Z=$P(^USC(8932.1,Z,0),U,7)
Q $E(Z,3,4)_"^"_$E(Z,5,9)_"^"_$E(Z,1,2)
PROC(RETVAL,BDWV) ;EP
NEW BDWP,BDWC
S (BDWP,BDWC)=0 F S BDWP=$O(^AUPNVPRC("AD",BDWV,BDWP)) Q:BDWP'=+BDWP D
.S BDWC=BDWC+1
.N CS,ICDP ;ihs/cmi/maw 10/17/2012 patch 4 added coding system for icd10
.S ICDP=$P($G(^AUPNVPRC(BDWP,0)),U)
.I $D(^ICDS(0)) S CS=$S($P($$ICDOP^ICDEX(ICDP,,,"I"),U,15)=31:"I10",1:"I9")
.I '$D(^ICDS(0)) S CS="I9"
.S RETVAL(BDWC)=$$VAL^XBDIQ1(9000010.08,BDWP,.01)_"^"_$P(^AUPNVPRC(BDWP,0),"^",6)_"^"_$P(^AUPNVPRC(BDWP,0),"^",8)_"^"_$$O($P(^AUPNVPRC(BDWP,0),"^",11))_"^"_$$X(BDWP)_"^"_$$VAL^XBDIQ1(9000010.08,BDWP,.16)
.S $P(RETVAL(BDWC),"^",10)=$G(CS) ;coding system
. N MOD1,MOD1C,MOD1I,MOD2,MOD2C,MOD2I,MOD1STR,MOD2STR
. S MOD1I=$$GET1^DIQ(9000010.08,BDWP,.17,"I")
. S MOD1=$$GET1^DIQ(9000010.08,BDWP,.17)
. S MOD1C=$$GET1^DIQ(81.3,MOD1I,.02)
. S MOD1STR=$S(MOD1]"":MOD1_"!"_MOD1C_"!"_"CPTM",1:"")
. S MOD2I=$$GET1^DIQ(9000010.08,BDWP,.18,"I")
. S MOD2=$$GET1^DIQ(9000010.08,BDWP,.18)
. S MOD2C=$$GET1^DIQ(81.3,MOD2I,.02)
. S MOD2STR=$S(MOD2]"":MOD2_"!"_MOD2C_"!"_"CPTM",1:"")
. I $G(MOD1STR)]"" D
.. S $P(RETVAL(BDWC),"^",13)=MOD1STR
.. I $G(MOD2STR)]"" S $P(RETVAL(BDWC),"^",13)=MOD1STR_"~"_MOD2STR
. I $G(MOD1STR)="" D
.. I $G(MOD2STR)]"" S $P(RETVAL(BDWC),"^",13)=MOD2STR
.S Y=$P(^AUPNVPRC(BDWP,0),"^",11) ;ien in file 200 should be in Y
.Q:'Y
.I $P(^DD(9000010.08,.11,0),U,2)[6 S Y=$G(^DIC(16,$P(^AUPNVPRC(BDWP,0),"^",11),"A3"))
.I Y="" Q
.;get USC1 node value
.S D=$P(^AUPNVPRC(BDWP,0),"^",3) Q:BDWP=""
.S D=$P($G(^AUPNVSIT(D,0)),"^"),D=$P(D,".",1)
.I D="" Q
.S G=$$PCC(Y,D)
.S $P(RETVAL(BDWC),"^",7)=G
.S $P(RETVAL(BDWC),"^",10)=$G(CS) ;coding system
.;the following is for CPT modifier
. N MOD1,MOD1C,MOD1I,MOD2,MOD2C,MOD2I,MOD1STR,MOD2STR
. S MOD1I=$$GET1^DIQ(9000010.08,BDWP,.17,"I")
. S MOD1=$$GET1^DIQ(9000010.08,BDWP,.17)
. S MOD1C=$$GET1^DIQ(81.3,MOD1I,.02)
. S MOD1STR=$S(MOD1]"":MOD1_"!"_MOD1C_"!"_"CPTM",1:"")
. S MOD2I=$$GET1^DIQ(9000010.08,BDWP,.18,"I")
. S MOD2=$$GET1^DIQ(9000010.08,BDWP,.18)
. S MOD2C=$$GET1^DIQ(81.3,MOD2I,.02)
. S MOD2STR=$S(MOD2]"":MOD2_"!"_MOD2C_"!"_"CPTM",1:"")
. I $G(MOD1STR)]"" D
.. S $P(RETVAL(C),"^",13)=MOD1STR
.. I $G(MOD2STR)]"" S $P(RETVAL(C),"^",13)=MOD1STR_"~"_MOD2STR
. I $G(MOD1STR)="" D
.. I $G(MOD2STR)]"" S $P(RETVAL(C),"^",13)=MOD2STR
.Q
Q
IMM(RETVAL,BDWV) ;EP
I '$D(^AUPNVSIT(BDWV)) Q
NEW BDWI,BDWC
K RETVAL S BDWC=0
S BDWI=0 F S BDWI=$O(^AUPNVIMM("AD",BDWV,BDWI)) Q:BDWI'=+BDWI S BDWC=BDWC+1 D
.S I=$P($G(^AUPNVIMM(BDWI,0)),"^")
.Q:'I
.Q:'$D(^AUTTIMM(I,0))
.S $P(RETVAL(BDWC),"^",4)=$P(^AUTTIMM(I,0),"^",$S($$BI:20,1:3)) ;IHS OLD CODE
.S $P(RETVAL(BDWC),"^",3)=$S('$$BI:"",1:$P(^AUTTIMM(I,0),"^",3))
.S $P(RETVAL(BDWC),"^",5)=$P(^AUPNVIMM(BDWI,0),"^",4)
Q
BI() ;IHS/CMI/LAB - new subroutine patch 4 1/5/1999
Q $S($O(^AUTTIMM(0))<100:0,1:1)
;
C(P) ;EP
NEW %
S %=$S($P(^DD(9000010.06,.01,0),"^",2)[200:$P($G(^VA(200,P,9999999)),"^",2),1:$P($G(^DIC(6,P,9999999)),"^",2))
Q %
A ;EP
S %=$S($P(^DD(9000010.06,.01,0),"^",2)[200:$P($G(^VA(200,P,9999999)),"^"),1:$P($G(^DIC(6,P,9999999)),"^")) Q
Q
F ;EP
S %=$$VALI^XBDIQ1($S($P(^DD(9000010.06,.01,0),"^",2)[200:200,1:6),P,$S($P(^DD(9000010.06,.01,0),"^",2)[200:53.5,1:2))
Q
D ;EP
D F
Q:%=""
S %=$P($G(^DIC(7,%,9999999)),"^")
Q
;
X(Z) ; ;diagnosis done for
NEW % S %=""
NEW M S M=$P(^AUPNVPRC(Z,0),"^",5)
NEW V S V=$P(^AUPNVPRC(Z,0),"^",3)
S I=$$PRIMPOV^APCLV(V,"I") I M=I S %=1 Q %
F I=1:1:25 Q:% S J=$$SECPOV^APCLV(V,"I",I) I J]"",J=M S %=I+1
Q %
O(P) ;EP
I $G(P)="" Q ""
NEW A,%
D A
I %="" Q ""
S A=%,%=""
D D
I %="" Q ""
S %=A_%
Q %
;
MCD(BDWV) ;EP
NEW P,%
S P=$P(^AUPNVSIT(BDWV,0),"^",5)
I 'P Q ""
S %=$$MCD^AUPNPAT(DFN,$P($P(^AUPNVSIT(BDWV,0),"^"),".")) S %=$S(%=1:"Y",%=0:"N",1:"")
Q %
MCR(BDWV) ;
NEW P,%
S P=$P(^AUPNVSIT(BDWV,0),"^",5)
I 'P Q ""
S %=$$MCR^AUPNPAT(DFN,$P($P(^AUPNVSIT(BDWV,0),"^"),".")) S %=$S(%=1:"Y",%=0:"N",1:"")
Q %
;
PI(BDWV) ;EP
NEW P,%
S P=$P(^AUPNVSIT(BDWV,0),"^",5)
I 'P Q ""
S %=$$PI^AUPNPAT(DFN,$P($P(^AUPNVSIT(BDWV,0),"^"),".")) S %=$S(%=1:"Y",%=0:"N",1:"")
Q %
HTN(BDWV,F) ;EP - is htn documented for this patient ever? Y or N retured
NEW R,X,E,BDWG,P
S P=$P(^AUPNVSIT(BDWV,0),"^",5)
I 'P Q ""
S R=""
I '$D(^DPT(P)) Q R
I $P(^DPT(P,0),"^",19) Q R
I '$D(^AUPNVPOV("AC",P)) Q R ;no povs on file
NEW X,E S X=P_"^LAST DX [SURVEILLANCE HYPERTENSION" S E=$$START1^APCLDF(X,"BDWG(")
I $D(BDWG(1)) Q $S(F="Y":"Y",1:$P(BDWG(1),"^"))
Q $S(F="Y":"N",1:"")
;
MED(RETVAL,BDWV) ;EP
K RETVAL
I $P($G(^BDWSITE(1,11)),U,1) Q
I '$G(BDWV) Q
I '$D(^AUPNVSIT(BDWV)) Q
NEW BDWI,BDWC,BDWD,BDWQ,BDWNDC,BDWCLS
S (BDWI,BDWC)=0 F S BDWI=$O(^AUPNVMED("AD",BDWV,BDWI)) Q:BDWI'=+BDWI D
.Q:'$D(^AUPNVMED(BDWI,0)) ;cmi/anch/maw 9/11/2007 patch 2
.S BDWD=$P(^AUPNVMED(BDWI,0),"^") Q:'$D(^PSDRUG(BDWD,0))
.S BDWC=BDWC+1
.S BDWQ=$P(^AUPNVMED(BDWI,0),"^",6)
.S BDWNDC=$P($G(^PSDRUG($P(^AUPNVMED(BDWI,0),"^"),2)),"^",4)
.I BDWNDC="" S BDWNDC=$P($G(^PSDRUG($P(^AUPNVMED(BDWI,0),"^"),2)),"^",4)
.S BDWCLS=$P(^PSDRUG($P(^AUPNVMED(BDWI,0),"^"),0),"^",2)
.S RETVAL(BDWC)=$P(^PSDRUG(BDWD,0),"^")_"^"_BDWQ_"^"_BDWNDC_"^"_BDWCLS
.Q
Q
PAP(V) ;EP - was pap performed Y/N
I '$G(V) Q ""
I $P($G(^BDWSITE(1,11)),U,1) Q ""
NEW T S T=$O(^ATXLAB("B","BDW PAP SMEAR LAB TESTS",0))
I 'T Q ""
NEW X,Y,Z S Y="N",X=0 F S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X!(Y="Y") S Z=$P(^AUPNVLAB(X,0),U) I $D(^ATXLAB(T,21,"B",Z)) S Y="Y"
Q Y
GLUCOSE(V) ;EP - return glucose test value on this visit
I '$G(V) Q ""
I $P($G(^BDWSITE(1,11)),U,1) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0))
I 'T Q ""
NEW X,Y,Z S Y="",X=0 F S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X!(Y]"") S Z=$P(^AUPNVLAB(X,0),U) I $D(^ATXLAB(T,21,"B",Z)) S Y=$P(^AUPNVLAB(X,0),U,4)
Q Y
HGBA1C(V) ;EP - called to return value of HGBA1C if done on this visit
;V is visit ien
NEW R
S R=""
I '$D(^AUPNVSIT(V)) Q R
I '$D(^AUPNVLAB("AD",V)) Q R ;no v labs to check
I '$D(^ATXLAB("B","DM AUDIT HGB A1C TAX")) Q R
NEW Y S Y=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
I 'Y Q R ;no taxonomy to look at
NEW X,Z
S X=0 F S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X S Z=$P(^AUPNVLAB(X,0),U) I Z,$D(^ATXLAB(Y,21,"B",Z)) S R=$P(^AUPNVLAB(X,0),U,4)
Q R
;
ACE(V) ;EP - ace inhibitor filled this visit
;V is visit ien
I '$D(^AUPNVSIT(V)) Q ""
I '$D(^AUPNVMED("AD",V)) Q "N" ;no v meds to check
NEW Y S Y=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
I 'Y Q ""
NEW X,Z,R
S R=""
S X=0 F S X=$O(^AUPNVMED("AD",V,X)) Q:X'=+X S Z=$P(^AUPNVMED(X,0),U) I $D(^ATXAX(Y,21,"B",Z)) S R=1
Q $S($G(R):"Y",1:"N")
;
MC(RETVAL,BDWV) ;EP
;medical condition, at this time health factors only
K RETVAL
I $P($G(^BDWSITE(1,11)),U,1) Q
I '$G(BDWV) Q
I '$D(^AUPNVSIT(BDWV)) Q
NEW BDWI,BDWH,BDWC
S (BDWC,BDWI)=0
F S BDWI=$O(^AUPNVHF("AD",BDWV,BDWI)) Q:BDWI'=+BDWI D
.S BDWH=$P($G(^AUPNVHF(BDWI,0)),"^")
.Q:BDWH=""
.Q:'$D(^AUTTHF(BDWH,0))
.S BDWC=BDWC+1
.S RETVAL(BDWC)="HF"_"^"_$P(^AUTTHF(BDWH,0),"^")_"^"_$P(^AUTTHF(BDWH,0),"^",2)_"^"_$$VAL^XBDIQ1(9999999.64,BDWH,.03)_"^"_$S($P(^AUTTHF(BDWH,0),"^",3)]"":$P(^AUTTHF($P(^AUTTHF(BDWH,0),"^",3),0),"^",2),1:"")
.Q
Q
CDEATH(PAT) ;-- get the cause of death and coding system
N CDI,CD,CS
S CDI=$$GET1^DIQ(9000001,PAT,1114,"I")
I 'CDI Q ""
S CD=$$GET1^DIQ(9000001,PAT,1114)
S CS=$S($D(^ICDS(0)):$P($$ICDDX^ICDEX(CD),U,20),1:"")
Q CD_U_U_$S(CS=30:"I10",1:"I9")
;
BDWUTIL1 ; IHS/CMI/LAB - Data Warehouse Utilities ;
+1 ;;1.0;IHS DATA WAREHOUSE;**1,2,4**;JAN 23, 2006;Build 24
+2 ;
+3 ;
+4 ;
ORF(P) ;EP patient has ORF?
+1 IF '$GET(P)
QUIT 0
+2 NEW FLAG,D
+3 SET FLAG=0
+4 ;
+5 SET D=0
+6 FOR
SET D=$ORDER(^AUPNPAT(P,41,D))
IF +D=0
QUIT
Begin DoDot:1
+7 ;only want ORFs
IF $PIECE($GET(^AGFAC(D,0)),"^",21)'="Y"
QUIT
+8 ;found one
SET FLAG=1
+9 QUIT
End DoDot:1
+10 QUIT FLAG
CHART(V) ;PEP - returns ASUFAC_HRN ( 12 digits, HRN is left zero filled)
+1 ;V = visit ien, returns asufac_hrn for this visit
+2 NEW L,%,C,S,P,Z
+3 SET %=""
+4 ;p4
IF V=""
QUIT $$CHARTREG^BDWUTIL1(DFN)
+5 ;bogus visit
IF '$DATA(^AUPNVSIT(V,0))
QUIT %
+6 SET Z=^AUPNVSIT(V,0)
+7 ;get patient pointer
SET P=$PIECE(Z,U,5)
+8 ;no patient so quit
IF 'P
QUIT %
+9 ;location of encounter of visit
SET L=$PIECE(Z,U,6)
+10 ;if no loc then quit, shouldn't happen
IF 'L
QUIT ""
+11 ;get hrn at loc of enc if have one use it
IF $DATA(^AUPNPAT(P,41,L,0))
SET %=$$GETCHART(P,L)
IF %]""
QUIT %
+12 ;get hrn at rpms site, if have one use it
SET L=$PIECE($GET(^AUTTSITE(1,0)),U)
SET %=$$GETCHART(P,L)
IF %]""
QUIT %
+13 ;get hrn at logged in site, if have one use it
IF $GET(DUZ(2))
SET L=DUZ(2)
SET %=$$GETCHART(P,L)
IF %]""
QUIT %
+14 ;get first one in multiple that is an official reg fac
SET L=0
FOR
SET L=$ORDER(^AUPNPAT(P,41,L))
IF L'=+L!(%]"")
QUIT
SET %=$$GETCHART(P,L)
+15 QUIT %
GETCHART(P,L) ;
+1 NEW R,S
+2 SET R=""
+3 ;not an official reg fac so quit, must be an orf
IF $PIECE($GET(^AGFAC(L,0)),U,21)'="Y"
QUIT ""
+4 ;get asufac for this location
SET S=$PIECE(^AUTTLOC(L,0),U,10)
+5 IF S=""
QUIT ""
+6 ;get hrn for this location
SET C=$PIECE($GET(^AUPNPAT(P,41,L,0)),U,2)
+7 IF C=""
QUIT ""
+8 ;return asufac_hrn
SET R=S_C
+9 QUIT R
+10 ;
CHARTREG(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNPAT(P))
QUIT ""
+3 NEW L,%,C,S
+4 SET %=""
+5 ;get hrn at rpms site, if have one use it
SET L=$PIECE($GET(^AUTTSITE(1,0)),U)
SET %=$$GETCHART(P,L)
IF %]""
QUIT %
+6 ;get hrn at logged in site, if have one use it
IF $GET(DUZ(2))
SET L=DUZ(2)
SET %=$$GETCHART(P,L)
IF %]""
QUIT %
+7 ;get first one in multiple that is an official reg fac
SET L=0
FOR
SET L=$ORDER(^AUPNPAT(P,41,L))
IF L'=+L!(%]"")
QUIT
SET %=$$GETCHART(P,L)
+8 QUIT %
HDL(V) ;
+1 QUIT $$LABDONE^BDWUTIL(V,"DM AUDIT HDL TAX")
HDLVALUE(V) ;
+1 QUIT $$LABRES^BDWUTIL(V,"DM AUDIT HDL TAX")
+2 ;
LDL(V) ;
+1 QUIT $$LABDONE^BDWUTIL(V,"DM AUDIT LDL CHOLESTEROL TAX")
+2 ;
LDLVALUE(V) ;
+1 QUIT $$LABRES^BDWUTIL(V,"DM AUDIT LDL CHOLESTEROL TAX")
+2 ;
TRI(V) ;
+1 QUIT $$LABDONE^BDWUTIL(V,"DM AUDIT TRIGLYCERIDE TAX")
+2 ;
TRIVALUE(V) ;
+1 QUIT $$LABRES^BDWUTIL(V,"DM AUDIT TRIGLYCERIDE TAX")
+2 ;
PSA(V) ;
+1 QUIT $$LABDONE^BDWUTIL(V,"BDW PSA TESTS TAX")
+2 ;
FECAL(V) ;
+1 QUIT $$LABDONE^BDWUTIL(V,"APCH FECAL OCCULT BLOOD")
+2 ;
NLAB(V) ;
+1 NEW X,Y
+2 SET (X,Y)=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",V,X))
IF X'=+X
QUIT
SET Y=Y+1
+3 QUIT Y
CHSPO(V) ;EP return vendor type from VCHS
+1 IF '$GET(V)
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 NEW C
SET C=$ORDER(^AUPNVCHS("AD",V,0))
+4 IF 'C
QUIT ""
+5 IF '$DATA(^AUPNVCHS(C,0))
QUIT ""
+6 NEW A
+7 SET A=$PIECE(^AUPNVCHS(C,0),U)
+8 SET A=$PIECE($GET(^AUTTLOC(A,0)),U,10)
+9 QUIT $PIECE(^AUPNVCHS(C,0),U,4)_"^"_A
ST(RETVAL,BDWV) ;EP -
+1 KILL RETVAL
+2 IF '$GET(BDWV)
QUIT
+3 IF '$DATA(^AUPNVSIT(BDWV))
QUIT
+4 NEW BDWI,BDWC,BDWE
+5 SET (BDWI,BDWC)=0
+6 FOR
SET BDWI=$ORDER(^AUPNVSK("AD",BDWV,BDWI))
IF BDWI'=+BDWI
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNVSK(BDWI,0))
QUIT
+8 SET BDWE=$PIECE(^AUPNVSK(BDWI,0),"^")
+9 IF '$DATA(^AUTTSK(BDWE,0))
QUIT
+10 SET BDWE=$PIECE(^AUTTSK(BDWE,0),"^",2)
+11 SET BDWC=BDWC+1
SET RETVAL(BDWC)=BDWE_"^"_$PIECE(^AUPNVSK(BDWI,0),"^",4)_"^"_$PIECE(^AUPNVSK(BDWI,0),"^",5)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
IFC(RETVAL,BDWV) ;EP -
+1 KILL RETVAL
+2 IF '$GET(BDWV)
QUIT
+3 IF '$DATA(^AUPNVSIT(BDWV))
QUIT
+4 NEW BDWI,BDWC,BDWE,BDWIE
+5 SET (BDWI,BDWC)=0
+6 FOR
SET BDWI=$ORDER(^AUPNVIF("AD",BDWV,BDWI))
IF BDWI'=+BDWI
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNVIF(BDWI,0))
QUIT
+8 SET BDWIE=$$GET1^DIQ(9000010.44,BDWI,.01,"I")
+9 SET BDWE=$$GET1^DIQ(9000010.44,BDWI,.01)
+10 SET BDWC=BDWC+1
SET RETVAL(BDWC)=BDWIE_"^"_BDWE
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
PROV(RETVAL,BDWV) ;EP
+1 NEW BDWP,BDWS,BDWC,BDWPIEN,BDWCS,BDWAD,X,Y,G,D
+2 KILL RETVAL
+3 IF '$DATA(^AUPNVPRV("AD",BDWV))
QUIT
+4 SET BDWP=""
SET BDWCS=1
+5 FOR
SET BDWP=$ORDER(^AUPNVPRV("AD",BDWV,BDWP))
IF BDWP'=+BDWP
QUIT
Begin DoDot:1
+6 IF '$DATA(^AUPNVPRV(BDWP,0))
QUIT
+7 IF $PIECE(^AUPNVPRV(BDWP,0),"^",4)="P"
SET BDWC=1
+8 IF $PIECE(^AUPNVPRV(BDWP,0),"^",4)'="P"
SET BDWCS=BDWCS+1
SET BDWC=BDWCS
+9 SET BDWPIEN=$PIECE(^AUPNVPRV(BDWP,0),"^")
+10 SET BDWAD=$$O(BDWPIEN)
+11 SET RETVAL(BDWC)=$PIECE(^AUPNVPRV(BDWP,0),"^")_"^"_$SELECT($PIECE(^DD(9000010.06,.01,0),"^",2)[200:200,1:6)_"^"_BDWAD_"^"_$$C(BDWPIEN)_"^"_$SELECT($EXTRACT(BDWAD,2,3)=17:1,1:"")
+12 ;6th is classification
+13 ;7th is specialty
+14 ;8th is type
+15 ;ien in file 200 should be in Y
SET Y=BDWPIEN
+16 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
SET Y=$GET(^DIC(16,BDWPIEN,"A3"))
+17 IF Y=""
QUIT
+18 ;get USC1 node value
+19 SET D=$PIECE(^AUPNVPRV(BDWP,0),"^",3)
IF D=""
QUIT
+20 SET D=$PIECE($GET(^AUPNVSIT(D,0)),"^")
SET D=$PIECE(D,".",1)
+21 IF D=""
QUIT
+22 SET G=$$PCC(Y,D)
+23 SET $PIECE(RETVAL(BDWC),"^",6)=G
+24 QUIT
End DoDot:1
+25 QUIT
PCC(P,D) ;EP - RETURN CLASS^SPEC^TYPE for provider P on date D
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(D)=""
QUIT ""
+3 IF '$DATA(^VA(200,P,0))
QUIT ""
+4 IF '$ORDER(^VA(200,P,"USC1",0))
QUIT ""
+5 NEW X,Y,Z
+6 SET (X,Z)=0
FOR
SET X=$ORDER(^VA(200,P,"USC1",X))
IF X'=+X!(Z)
QUIT
Begin DoDot:1
+7 SET Y=$GET(^VA(200,P,"USC1",0))
+8 ;both dates and a match
IF $PIECE(Y,U,2)]""
IF $PIECE(Y,U,3)]""
IF D'<$PIECE(Y,U,2)
IF D'>$PIECE(Y,U,3)
SET Z=X
QUIT
+9 ;beg date, no expire visit after beg
IF $PIECE(Y,U,2)]""
IF $PIECE(Y,U,3)=""
IF D'<$PIECE(Y,U,2)
SET Z=X
QUIT
+10 QUIT
End DoDot:1
+11 IF 'Z
SET Z=$ORDER(^VA(200,P,"USC1",0))
+12 SET Z=$PIECE(^VA(200,P,"USC1",Z,0),U)
+13 IF 'Z
QUIT ""
+14 IF '$DATA(^USC(8932.1,Z,0))
QUIT ""
+15 SET Z=$PIECE(^USC(8932.1,Z,0),U,7)
+16 QUIT $EXTRACT(Z,3,4)_"^"_$EXTRACT(Z,5,9)_"^"_$EXTRACT(Z,1,2)
PROC(RETVAL,BDWV) ;EP
+1 NEW BDWP,BDWC
+2 SET (BDWP,BDWC)=0
FOR
SET BDWP=$ORDER(^AUPNVPRC("AD",BDWV,BDWP))
IF BDWP'=+BDWP
QUIT
Begin DoDot:1
+3 SET BDWC=BDWC+1
+4 ;ihs/cmi/maw 10/17/2012 patch 4 added coding system for icd10
NEW CS,ICDP
+5 SET ICDP=$PIECE($GET(^AUPNVPRC(BDWP,0)),U)
+6 IF $DATA(^ICDS(0))
SET CS=$SELECT($PIECE($$ICDOP^ICDEX(ICDP,,,"I"),U,15)=31:"I10",1:"I9")
+7 IF '$DATA(^ICDS(0))
SET CS="I9"
+8 SET RETVAL(BDWC)=$$VAL^XBDIQ1(9000010.08,BDWP,.01)_"^"_$PIECE(^AUPNVPRC(BDWP,0),"^",6)_"^"_$PIECE(^AUPNVPRC(BDWP,0),"^",8)_"^"_$$O($PIECE(^AUPNVPRC(BDWP,0),"^",11))_"^"_$$X(BDWP)_"^"_$$VAL^XBDIQ1(9000010.08,BDWP,.16)
+9 ;coding system
SET $PIECE(RETVAL(BDWC),"^",10)=$GET(CS)
+10 NEW MOD1,MOD1C,MOD1I,MOD2,MOD2C,MOD2I,MOD1STR,MOD2STR
+11 SET MOD1I=$$GET1^DIQ(9000010.08,BDWP,.17,"I")
+12 SET MOD1=$$GET1^DIQ(9000010.08,BDWP,.17)
+13 SET MOD1C=$$GET1^DIQ(81.3,MOD1I,.02)
+14 SET MOD1STR=$SELECT(MOD1]"":MOD1_"!"_MOD1C_"!"_"CPTM",1:"")
+15 SET MOD2I=$$GET1^DIQ(9000010.08,BDWP,.18,"I")
+16 SET MOD2=$$GET1^DIQ(9000010.08,BDWP,.18)
+17 SET MOD2C=$$GET1^DIQ(81.3,MOD2I,.02)
+18 SET MOD2STR=$SELECT(MOD2]"":MOD2_"!"_MOD2C_"!"_"CPTM",1:"")
+19 IF $GET(MOD1STR)]""
Begin DoDot:2
+20 SET $PIECE(RETVAL(BDWC),"^",13)=MOD1STR
+21 IF $GET(MOD2STR)]""
SET $PIECE(RETVAL(BDWC),"^",13)=MOD1STR_"~"_MOD2STR
End DoDot:2
+22 IF $GET(MOD1STR)=""
Begin DoDot:2
+23 IF $GET(MOD2STR)]""
SET $PIECE(RETVAL(BDWC),"^",13)=MOD2STR
End DoDot:2
+24 ;ien in file 200 should be in Y
SET Y=$PIECE(^AUPNVPRC(BDWP,0),"^",11)
+25 IF 'Y
QUIT
+26 IF $PIECE(^DD(9000010.08,.11,0),U,2)[6
SET Y=$GET(^DIC(16,$PIECE(^AUPNVPRC(BDWP,0),"^",11),"A3"))
+27 IF Y=""
QUIT
+28 ;get USC1 node value
+29 SET D=$PIECE(^AUPNVPRC(BDWP,0),"^",3)
IF BDWP=""
QUIT
+30 SET D=$PIECE($GET(^AUPNVSIT(D,0)),"^")
SET D=$PIECE(D,".",1)
+31 IF D=""
QUIT
+32 SET G=$$PCC(Y,D)
+33 SET $PIECE(RETVAL(BDWC),"^",7)=G
+34 ;coding system
SET $PIECE(RETVAL(BDWC),"^",10)=$GET(CS)
+35 ;the following is for CPT modifier
+36 NEW MOD1,MOD1C,MOD1I,MOD2,MOD2C,MOD2I,MOD1STR,MOD2STR
+37 SET MOD1I=$$GET1^DIQ(9000010.08,BDWP,.17,"I")
+38 SET MOD1=$$GET1^DIQ(9000010.08,BDWP,.17)
+39 SET MOD1C=$$GET1^DIQ(81.3,MOD1I,.02)
+40 SET MOD1STR=$SELECT(MOD1]"":MOD1_"!"_MOD1C_"!"_"CPTM",1:"")
+41 SET MOD2I=$$GET1^DIQ(9000010.08,BDWP,.18,"I")
+42 SET MOD2=$$GET1^DIQ(9000010.08,BDWP,.18)
+43 SET MOD2C=$$GET1^DIQ(81.3,MOD2I,.02)
+44 SET MOD2STR=$SELECT(MOD2]"":MOD2_"!"_MOD2C_"!"_"CPTM",1:"")
+45 IF $GET(MOD1STR)]""
Begin DoDot:2
+46 SET $PIECE(RETVAL(C),"^",13)=MOD1STR
+47 IF $GET(MOD2STR)]""
SET $PIECE(RETVAL(C),"^",13)=MOD1STR_"~"_MOD2STR
End DoDot:2
+48 IF $GET(MOD1STR)=""
Begin DoDot:2
+49 IF $GET(MOD2STR)]""
SET $PIECE(RETVAL(C),"^",13)=MOD2STR
End DoDot:2
+50 QUIT
End DoDot:1
+51 QUIT
IMM(RETVAL,BDWV) ;EP
+1 IF '$DATA(^AUPNVSIT(BDWV))
QUIT
+2 NEW BDWI,BDWC
+3 KILL RETVAL
SET BDWC=0
+4 SET BDWI=0
FOR
SET BDWI=$ORDER(^AUPNVIMM("AD",BDWV,BDWI))
IF BDWI'=+BDWI
QUIT
SET BDWC=BDWC+1
Begin DoDot:1
+5 SET I=$PIECE($GET(^AUPNVIMM(BDWI,0)),"^")
+6 IF 'I
QUIT
+7 IF '$DATA(^AUTTIMM(I,0))
QUIT
+8 ;IHS OLD CODE
SET $PIECE(RETVAL(BDWC),"^",4)=$PIECE(^AUTTIMM(I,0),"^",$SELECT($$BI:20,1:3))
+9 SET $PIECE(RETVAL(BDWC),"^",3)=$SELECT('$$BI:"",1:$PIECE(^AUTTIMM(I,0),"^",3))
+10 SET $PIECE(RETVAL(BDWC),"^",5)=$PIECE(^AUPNVIMM(BDWI,0),"^",4)
End DoDot:1
+11 QUIT
BI() ;IHS/CMI/LAB - new subroutine patch 4 1/5/1999
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))<100:0,1:1)
+2 ;
C(P) ;EP
+1 NEW %
+2 SET %=$SELECT($PIECE(^DD(9000010.06,.01,0),"^",2)[200:$PIECE($GET(^VA(200,P,9999999)),"^",2),1:$PIECE($GET(^DIC(6,P,9999999)),"^",2))
+3 QUIT %
A ;EP
+1 SET %=$SELECT($PIECE(^DD(9000010.06,.01,0),"^",2)[200:$PIECE($GET(^VA(200,P,9999999)),"^"),1:$PIECE($GET(^DIC(6,P,9999999)),"^"))
QUIT
+2 QUIT
F ;EP
+1 SET %=$$VALI^XBDIQ1($SELECT($PIECE(^DD(9000010.06,.01,0),"^",2)[200:200,1:6),P,$SELECT($PIECE(^DD(9000010.06,.01,0),"^",2)[200:53.5,1:2))
+2 QUIT
D ;EP
+1 DO F
+2 IF %=""
QUIT
+3 SET %=$PIECE($GET(^DIC(7,%,9999999)),"^")
+4 QUIT
+5 ;
X(Z) ; ;diagnosis done for
+1 NEW %
SET %=""
+2 NEW M
SET M=$PIECE(^AUPNVPRC(Z,0),"^",5)
+3 NEW V
SET V=$PIECE(^AUPNVPRC(Z,0),"^",3)
+4 SET I=$$PRIMPOV^APCLV(V,"I")
IF M=I
SET %=1
QUIT %
+5 FOR I=1:1:25
IF %
QUIT
SET J=$$SECPOV^APCLV(V,"I",I)
IF J]""
IF J=M
SET %=I+1
+6 QUIT %
O(P) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 NEW A,%
+3 DO A
+4 IF %=""
QUIT ""
+5 SET A=%
SET %=""
+6 DO D
+7 IF %=""
QUIT ""
+8 SET %=A_%
+9 QUIT %
+10 ;
MCD(BDWV) ;EP
+1 NEW P,%
+2 SET P=$PIECE(^AUPNVSIT(BDWV,0),"^",5)
+3 IF 'P
QUIT ""
+4 SET %=$$MCD^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(BDWV,0),"^"),"."))
SET %=$SELECT(%=1:"Y",%=0:"N",1:"")
+5 QUIT %
MCR(BDWV) ;
+1 NEW P,%
+2 SET P=$PIECE(^AUPNVSIT(BDWV,0),"^",5)
+3 IF 'P
QUIT ""
+4 SET %=$$MCR^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(BDWV,0),"^"),"."))
SET %=$SELECT(%=1:"Y",%=0:"N",1:"")
+5 QUIT %
+6 ;
PI(BDWV) ;EP
+1 NEW P,%
+2 SET P=$PIECE(^AUPNVSIT(BDWV,0),"^",5)
+3 IF 'P
QUIT ""
+4 SET %=$$PI^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(BDWV,0),"^"),"."))
SET %=$SELECT(%=1:"Y",%=0:"N",1:"")
+5 QUIT %
HTN(BDWV,F) ;EP - is htn documented for this patient ever? Y or N retured
+1 NEW R,X,E,BDWG,P
+2 SET P=$PIECE(^AUPNVSIT(BDWV,0),"^",5)
+3 IF 'P
QUIT ""
+4 SET R=""
+5 IF '$DATA(^DPT(P))
QUIT R
+6 IF $PIECE(^DPT(P,0),"^",19)
QUIT R
+7 ;no povs on file
IF '$DATA(^AUPNVPOV("AC",P))
QUIT R
+8 NEW X,E
SET X=P_"^LAST DX [SURVEILLANCE HYPERTENSION"
SET E=$$START1^APCLDF(X,"BDWG(")
+9 IF $DATA(BDWG(1))
QUIT $SELECT(F="Y":"Y",1:$PIECE(BDWG(1),"^"))
+10 QUIT $SELECT(F="Y":"N",1:"")
+11 ;
MED(RETVAL,BDWV) ;EP
+1 KILL RETVAL
+2 IF $PIECE($GET(^BDWSITE(1,11)),U,1)
QUIT
+3 IF '$GET(BDWV)
QUIT
+4 IF '$DATA(^AUPNVSIT(BDWV))
QUIT
+5 NEW BDWI,BDWC,BDWD,BDWQ,BDWNDC,BDWCLS
+6 SET (BDWI,BDWC)=0
FOR
SET BDWI=$ORDER(^AUPNVMED("AD",BDWV,BDWI))
IF BDWI'=+BDWI
QUIT
Begin DoDot:1
+7 ;cmi/anch/maw 9/11/2007 patch 2
IF '$DATA(^AUPNVMED(BDWI,0))
QUIT
+8 SET BDWD=$PIECE(^AUPNVMED(BDWI,0),"^")
IF '$DATA(^PSDRUG(BDWD,0))
QUIT
+9 SET BDWC=BDWC+1
+10 SET BDWQ=$PIECE(^AUPNVMED(BDWI,0),"^",6)
+11 SET BDWNDC=$PIECE($GET(^PSDRUG($PIECE(^AUPNVMED(BDWI,0),"^"),2)),"^",4)
+12 IF BDWNDC=""
SET BDWNDC=$PIECE($GET(^PSDRUG($PIECE(^AUPNVMED(BDWI,0),"^"),2)),"^",4)
+13 SET BDWCLS=$PIECE(^PSDRUG($PIECE(^AUPNVMED(BDWI,0),"^"),0),"^",2)
+14 SET RETVAL(BDWC)=$PIECE(^PSDRUG(BDWD,0),"^")_"^"_BDWQ_"^"_BDWNDC_"^"_BDWCLS
+15 QUIT
End DoDot:1
+16 QUIT
PAP(V) ;EP - was pap performed Y/N
+1 IF '$GET(V)
QUIT ""
+2 IF $PIECE($GET(^BDWSITE(1,11)),U,1)
QUIT ""
+3 NEW T
SET T=$ORDER(^ATXLAB("B","BDW PAP SMEAR LAB TESTS",0))
+4 IF 'T
QUIT ""
+5 NEW X,Y,Z
SET Y="N"
SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",V,X))
IF X'=+X!(Y="Y")
QUIT
SET Z=$PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(T,21,"B",Z))
SET Y="Y"
+6 QUIT Y
GLUCOSE(V) ;EP - return glucose test value on this visit
+1 IF '$GET(V)
QUIT ""
+2 IF $PIECE($GET(^BDWSITE(1,11)),U,1)
QUIT ""
+3 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0))
+4 IF 'T
QUIT ""
+5 NEW X,Y,Z
SET Y=""
SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",V,X))
IF X'=+X!(Y]"")
QUIT
SET Z=$PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(T,21,"B",Z))
SET Y=$PIECE(^AUPNVLAB(X,0),U,4)
+6 QUIT Y
HGBA1C(V) ;EP - called to return value of HGBA1C if done on this visit
+1 ;V is visit ien
+2 NEW R
+3 SET R=""
+4 IF '$DATA(^AUPNVSIT(V))
QUIT R
+5 ;no v labs to check
IF '$DATA(^AUPNVLAB("AD",V))
QUIT R
+6 IF '$DATA(^ATXLAB("B","DM AUDIT HGB A1C TAX"))
QUIT R
+7 NEW Y
SET Y=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
+8 ;no taxonomy to look at
IF 'Y
QUIT R
+9 NEW X,Z
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",V,X))
IF X'=+X
QUIT
SET Z=$PIECE(^AUPNVLAB(X,0),U)
IF Z
IF $DATA(^ATXLAB(Y,21,"B",Z))
SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+11 QUIT R
+12 ;
ACE(V) ;EP - ace inhibitor filled this visit
+1 ;V is visit ien
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 ;no v meds to check
IF '$DATA(^AUPNVMED("AD",V))
QUIT "N"
+4 NEW Y
SET Y=$ORDER(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
+5 IF 'Y
QUIT ""
+6 NEW X,Z,R
+7 SET R=""
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVMED("AD",V,X))
IF X'=+X
QUIT
SET Z=$PIECE(^AUPNVMED(X,0),U)
IF $DATA(^ATXAX(Y,21,"B",Z))
SET R=1
+9 QUIT $SELECT($GET(R):"Y",1:"N")
+10 ;
MC(RETVAL,BDWV) ;EP
+1 ;medical condition, at this time health factors only
+2 KILL RETVAL
+3 IF $PIECE($GET(^BDWSITE(1,11)),U,1)
QUIT
+4 IF '$GET(BDWV)
QUIT
+5 IF '$DATA(^AUPNVSIT(BDWV))
QUIT
+6 NEW BDWI,BDWH,BDWC
+7 SET (BDWC,BDWI)=0
+8 FOR
SET BDWI=$ORDER(^AUPNVHF("AD",BDWV,BDWI))
IF BDWI'=+BDWI
QUIT
Begin DoDot:1
+9 SET BDWH=$PIECE($GET(^AUPNVHF(BDWI,0)),"^")
+10 IF BDWH=""
QUIT
+11 IF '$DATA(^AUTTHF(BDWH,0))
QUIT
+12 SET BDWC=BDWC+1
+13 SET RETVAL(BDWC)="HF"_"^"_$PIECE(^AUTTHF(BDWH,0),"^")_"^"_$PIECE(^AUTTHF(BDWH,0),"^",2)_"^"_$$VAL^XBDIQ1(9999999.64,BDWH,.03)_"^"_$SELECT($PIECE(^AUTTHF(BDWH,0),"^",3)]"":$PIECE(^AUTTHF($PIECE(^AUTTHF(BDWH,0),"^",3),0),"^",2),1:"")
+14 QUIT
End DoDot:1
+15 QUIT
CDEATH(PAT) ;-- get the cause of death and coding system
+1 NEW CDI,CD,CS
+2 SET CDI=$$GET1^DIQ(9000001,PAT,1114,"I")
+3 IF 'CDI
QUIT ""
+4 SET CD=$$GET1^DIQ(9000001,PAT,1114)
+5 SET CS=$SELECT($DATA(^ICDS(0)):$PIECE($$ICDDX^ICDEX(CD),U,20),1:"")
+6 QUIT CD_U_U_$SELECT(CS=30:"I10",1:"I9")
+7 ;
