BDWUTIL ; IHS/CMI/LAB - DW UTILITIES ;
;;1.0;IHS DATA WAREHOUSE;**4**;JAN 23, 2006;Build 24
;
;
POVS(RETVAL,BDWV) ;EP
NEW BDWP,BDWS,BDWC,BDWY
K RETVAL
I '$D(^AUPNVPOV("AD",BDWV)) Q
S BDWP="",BDWY=0
I $P(^AUPNVSIT(BDWV,0),"^",7)="H" F S BDWY=$O(^AUPNVPOV("AD",BDWV,BDWY)) Q:BDWY'=+BDWY!(BDWP) I $P(^AUPNVPOV(BDWY,0),"^",12)="P" S BDWP=BDWY
I $P(^AUPNVSIT(BDWV,0),"^",7)'="H" S BDWP=$O(^AUPNVPOV("AD",BDWV,0))
S BDWC=1
I $P(^AUPNVSIT(BDWV,0),U,7)="H",'BDWP S RETVAL(BDWC)=""
I BDWP D ;ihs/cmi/maw 10/17/2012 patch 4 added coding system for icd10
. N CS,ICDP,CSE,COIP,PN
. S ICDP=$P($G(^AUPNVPOV(BDWP,0)),U)
. S PN=$TR($$GET1^DIQ(9000010.07,BDWP,.04),"|","") ;p5 ALPMR
. I $D(^ICDS(0)) S CS=$S($P($$ICDDX^ICDEX(ICDP),U,20)=30:"I10",1:"I9")
. I '$D(^ICDS(0)) S CS="I9"
. S COIP=$P($G(^AUPNVPOV(BDWP,0)),U,9)
. I $G(COIP) D
.. I $D(^ICDS(0)) S CSE=$S($P($$ICDDX^ICDEX(COIP),U,20)=30:"I10",1:"I9")
.. I '$D(^ICDS(0)) S CSE="I9"
. S RETVAL(BDWC)=$$VAL^XBDIQ1(9000010.07,BDWP,.01)_"^"_$P(^AUPNVPOV(BDWP,0),"^",7)_"^"_$$VAL^XBDIQ1(9000010.07,BDWP,.09)_"^"_$P(^AUPNVPOV(BDWP,0),"^",11)
. S $P(RETVAL(BDWC),"^",10)=$G(CS) ;coding system
. S $P(RETVAL(BDWC),"^",11)=$G(CSE) ;coding system
. S $P(RETVAL(BDWC),"^",12)=$TR($G(PN),"|","") ;provider narrative p5 ALPMR
S BDWS=0 F S BDWS=$O(^AUPNVPOV("AD",BDWV,BDWS)) Q:BDWS'=+BDWS D
. Q:BDWS=BDWP
. ;ihs/cmi/maw 10/17/2012 patch 4 added coding system for icd10
. N CS,ICDP,CSE,COIP,PN
. S ICDP=$P($G(^AUPNVPOV(BDWS,0)),U)
. S PN=$TR($$GET1^DIQ(9000010.07,BDWS,.04),"|","") ;p5 ALPMR
. I $D(^ICDS(0)) S CS=$S($P($$ICDDX^ICDEX(ICDP),U,20)=30:"I10",1:"I9")
. I '$D(^ICDS(0)) S CS="I9"
. S COIP=$P($G(^AUPNVPOV(BDWS,0)),U,9)
. I $G(COIP) D
.. I $D(^ICDS(0)) S CSE=$S($P($$ICDDX^ICDEX(COIP),U,20)=30:"I10",1:"I9")
.. I '$D(^ICDS(0)) S CSE="I9"
. S BDWC=BDWC+1,RETVAL(BDWC)=$$VAL^XBDIQ1(9000010.07,BDWS,.01)_"^"_$P(^AUPNVPOV(BDWS,0),"^",7)_"^"_$$VAL^XBDIQ1(9000010.07,BDWS,.09)_"^"_$P(^AUPNVPOV(BDWS,0),"^",11)
. S $P(RETVAL(BDWC),"^",10)=$G(CS) ;coding system
. S $P(RETVAL(BDWC),"^",11)=$G(CSE) ;coding system
. S $P(RETVAL(BDWC),"^",12)=$TR($G(PN),"|","") ;provider narrative p5 ALPMR
Q
DATE(D) ;EP - return YYYYMMDD from internal fm format
I $G(D)="" Q ""
Q ($E(D,1,3)+1700)_$E(D,4,7)
RZERO(V,L) ;ep right zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"
Q V
LZERO(V,L) ;EP - left zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
Q V
LBLK(V,L) ;left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
RBLK(V,L) ;EP right blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "
Q V
;
DISPER(V) ;EP - called to get ER disposition
I '$G(V) Q ""
I '$D(^AUPNVSIT(V)) Q ""
NEW Y S Y=$O(^AUPNVER("AD",V,0)) I 'Y Q ""
Q $$VALI^XBDIQ1(9000010.29,Y,.11)
CPT(RETVAL,V) ;EP cpt and quantity
K AUPNCPT,RETVAL,MOD1,MOD2
NEW X,C,E S X=$$CPT^AUPNCPT(V)
I '$D(AUPNCPT) Q
S (X,C)=0 F S X=$O(AUPNCPT(X)) Q:X'=+X D
. S C=C+1
. S RETVAL(C)=$P(AUPNCPT(X),"^")
.;ihs/cmi/maw p5 alpmr
. I $P(AUPNCPT(X),"^",4)=9000010.18 D
.. S E=$P(AUPNCPT(X),"^",5),$P(RETVAL(C),"^",2)=$P($G(^AUPNVCPT(E,0)),"^",16)
.. N MOD1,MOD1C,MOD1I,MOD2,MOD2C,MOD2I,MOD1STR,MOD2STR
.. S MOD1I=$$GET1^DIQ(9000010.18,E,.08,"I")
.. S MOD1=$$GET1^DIQ(9000010.18,E,.08)
.. S MOD1C=$$GET1^DIQ(81.3,MOD1I,.02)
.. S MOD1STR=$S(MOD1]"":MOD1_"!"_MOD1C_"!"_"CPTM",1:"")
.. S MOD2I=$$GET1^DIQ(9000010.18,E,.09,"I")
.. S MOD2=$$GET1^DIQ(9000010.18,E,.09)
.. S MOD2C=$$GET1^DIQ(81.3,MOD2I,.02)
.. S MOD2STR=$S(MOD2]"":MOD2_"!"_MOD2C_"!"_"CPTM",1:"")
.. I $G(MOD1STR)]"" D
... S $P(RETVAL(C),"^",3)=MOD1STR
... I $G(MOD2STR)]"" S $P(RETVAL(C),"^",3)=MOD1STR_"~"_MOD2STR
.. I $G(MOD1STR)="" D
... I $G(MOD2STR)]"" S $P(RETVAL(C),"^",3)=MOD2STR
Q
DSCHTYPE(V) ;EP
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I $P(^AUPNVSIT(V,0),"^",7)'="H" Q ""
NEW %,Y,Z
I $P(^AUPNVSIT(V,0),"^",3)="C" G CHSDT
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q Z
S Y=$$VALI^XBDIQ1(9000010.02,Z,.06)
I 'Y Q ""
I $P(^DD(9000010.02,.06,0),"^",2)[42.2 Q $P($G(^DIC(42.2,Y,9999999)),"^")
I $P(^DD(9000010.02,.06,0),"^",2)[405.1 Q $P($G(^DG(405.1,Y,"IHS")),"^")
Q ""
VENTYP(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 E,T
S E=$P(^AUPNVCHS(C,0),"^",14)
I 'E Q ""
S T=$$VAL^XBDIQ1(9999999.11,E,1103)
Q T
CHSDT ;
S Z=$O(^AUPNVCHS("AD",V,0)) I 'Z Q ""
S Y=$$VALI^XBDIQ1(9000010.03,Z,.08)
S Y=$S(Y="":"",Y=1:1,Y=2:3,Y=3:5,Y=4:7,Y=5:2,1:"")
Q Y
DSCHDATE(V) ;EP
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I $P(^AUPNVSIT(V,0),"^",7)'="H" Q ""
NEW Y,Z
S Z=$O(^AUPNVINP("AD",V,0)) I 'Z G CHSDD
S Y=$P(^AUPNVINP(Z,0),"^")
I Y="" Q Y
Q $P(Y,".")
CHSDD ;
S Z=$O(^AUPNVCHS("AD",V,0)) I 'Z Q Z
S Y=$P(^AUPNVCHS(Z,0),"^",7)
I Y="" Q Y
Q $P(Y,".")
LOS(V) ;EP
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I $P(^AUPNVSIT(V,0),"^",7)'="H" Q ""
NEW Y,Z,X,X1,X2
I $P(^AUPNVSIT(V,0),"^",3)="C" G CHSLOS
S Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q ""
S X1=$P($P(^AUPNVINP(Z,0),"^"),"."),X2=$P($P(^AUPNVSIT($P(^AUPNVINP(Z,0),"^",3),0),"^"),".") D ^%DTC
S:X=0 X=1
Q X
CHSLOS ;
S Z=$O(^AUPNVCHS("AD",V,0)) I 'Z Q ""
S X1=$P($P(^AUPNVCHS(Z,0),"^",7),"."),X2=$P($P(^AUPNVSIT($P(^AUPNVCHS(Z,0),"^",3),0),"^"),".") D ^%DTC
S:X=0 X=1
Q X
PHNAC(V) ;
I '$G(V) Q ""
I '$$PHN(V) Q "" ;not a phn visit
I $P(^AUPNVSIT(V,0),"^",7)="N" Q "03"
I $$CLINIC^APCLV(V,"C")=11 Q "01"
Q "02"
PHN(V) ;
;is one of the providers a CHN?
I '$G(V) Q ""
NEW X,%,D,N
I $$PRIMPROV^APCLV(V,"D")=13!($$PRIMPROV^APCLV(V,"D")=32) Q 1
S (X,%,N)=0 F S X=$O(^AUPNVPRV("AD",V,X)) Q:X'=+X I $P(^AUPNVPRV(X,0),"^",4)'="P" S N=N+1 S D=$$SECPROV^APCLV(V,"D",N) I D=13!(D=32) S %=1
Q %
LEVEL(V) ;EP
I '$G(V) Q ""
I '$$PHN(V) Q ""
NEW P S P=$O(^AUPNVPHN("AD",V,0))
I 'P Q ""
Q $P(^AUPNVPHN(P,0),"^",5)
;
MEAS(RETVAL,BDWV) ;EP -
K RETVAL
I $P($G(^BDWSITE(1,11)),U,1) Q
I '$D(^AUPNVSIT(BDWV)) Q
I '$D(^AUPNVMSR("AD",BDWV)) Q
NEW BDWC,BDWI,BDWM
S (BDWI,BDWC)=0 F S BDWI=$O(^AUPNVMSR("AD",BDWV,BDWI)) Q:BDWI'=+BDWI D
.S BDWM=$$VAL^XBDIQ1(9000010.01,BDWI,.01)
.;ihs/cmi/maw 06/05/2014 p5 ALPMR don't screen any measurement types
.;I BDWM'="BP",BDWM'="HT",BDWM'="WT" Q
.S BDWVAL=$P(^AUPNVMSR(BDWI,0),"^",4) I BDWM="HT"!(BDWM="WT") S BDWVAL=BDWVAL+.05,BDWVAL=+($P(BDWVAL,".")_"."_$E($P(BDWVAL,".",2),1))
.S BDWC=BDWC+1
.S RETVAL(BDWC)=$P(^AUTTMSR($P(^AUPNVMSR(BDWI,0),"^"),0),"^",3)_"^"_BDWVAL
.Q
Q
EXAM(RETVAL,BDWV) ;EP - return nth v exam on this visit
K RETVAL
I '$G(BDWV) Q
I '$D(^AUPNVSIT(BDWV)) Q
NEW BDWI,BDWC,BDWE
S (BDWI,BDWC)=0
F S BDWI=$O(^AUPNVXAM("AD",BDWV,BDWI)) Q:BDWI'=+BDWI D
.Q:'$D(^AUPNVXAM(BDWI,0))
.S BDWE=$P(^AUPNVXAM(BDWI,0),"^")
.I '$D(^AUTTEXAM(BDWE,0)) Q
.S BDWE=$P(^AUTTEXAM(BDWE,0),"^",2)
.S BDWC=BDWC+1,RETVAL(BDWC)=BDWE
.Q
Q
;
PED(RETVAL,BDWV) ;EP - return nth v patient ed on this visit
K RETVAL
I '$G(BDWV) Q
I '$D(^AUPNVSIT(BDWV)) Q
NEW BDWI,BDWC,BDWE
S (BDWI,BDWC)=0
F S BDWI=$O(^AUPNVPED("AD",BDWV,BDWI)) Q:BDWI'=+BDWI D
.Q:'$D(^AUPNVPED(BDWI,0))
.S BDWE=$P(^AUPNVPED(BDWI,0),"^")
.I '$D(^AUTTEDT(BDWE,0)) Q
.S BDWE=$P(^AUTTEDT(BDWE,0),"^",2)
.S BDWC=BDWC+1,RETVAL(BDWC)=BDWE
.I $P($G(^BDWSITE(1,11)),U,1) Q
.S RETVAL(BDWC)=RETVAL(BDWC)_"^"_$P(^AUPNVPED(BDWI,0),"^",6)_"^"_$P(^AUPNVPED(BDWI,0),"^",8)
.Q
Q
;
DENTCOST(V) ;COST OF THIS VISIT
I '$G(V) Q ""
NEW X,Y,C
S X=0,C=""
F S X=$O(^AUPNVDEN("AD",V,X)) Q:X'=+X S C=C+$P(^AUPNVDEN(X,0),U,7)
Q $S(C=0:"",1:$P((C+.5),"."))
DENT(RETVAL,BDWV) ;EP
I '$G(BDWV) Q
I '$D(^AUPNVSIT(BDWV)) Q
K RETVAL
NEW BDWI,BDWC
S (BDWI,BDWC)=0
F S BDWI=$O(^AUPNVDEN("AD",BDWV,BDWI)) Q:BDWI'=+BDWI D
.Q:'$D(^AUPNVDEN(BDWI,0))
.S BDWC=BDWC+1
.S RETVAL(BDWC)=$$VAL^XBDIQ1(9000010.05,BDWI,.01)_"^"_$P(^AUPNVDEN(BDWI,0),"^",4)_"^"_$P(^AUPNVDEN(BDWI,0),"^",7)_"^"_$S($P(^AUPNVSIT(BDWV,0),"^",3)="C":"K",1:"D")
.S $P(RETVAL(BDWC),"^",5)=$$DENTSSN(BDWV)
.I $P(^AUPNVDEN(BDWI,0),"^",5)]"" S $P(RETVAL(BDWC),"^",6)=$$VAL^XBDIQ1(9002010.03,$P(^AUPNVDEN(BDWI,0),"^",5),8801)
.S $P(RETVAL(BDWC),"^",7)=$P(^AUPNVDEN(BDWI,0),"^",6)
.I BDWC=1 S $P(RETVAL(BDWC,0),"^",8)=$$DENTCOST(BDWV)
Q
DENTSSN(V) ;EP - if a provider is a 52 get SSN
I '$G(V) Q ""
I '$D(^AUPNVSIT(V)) Q ""
NEW X,Y,S S S="",X=0 F S X=$O(^AUPNVPRV("AD",V,X)) Q:X'=+X!(S]"") S Y=$P(^AUPNVPRV(X,0),"^") D
.S D=$$CLS(Y)
.I D=52 S S=$$SSN(Y)
.Q
Q S
CLS(P) ;return ihs class code for provider P
I '$G(P) Q ""
NEW % S %=""
I $P(^DD(9000010.06,.01,0),"^",2)[200 D Q %
.Q:'$D(^VA(200,P))
.NEW %1 S %1=$P($G(^VA(200,P,"PS")),"^",5)
.I '%1 Q
.S %=$P($G(^DIC(7,%1,9999999)),"^")
.Q
I '$D(^DIC(6,P,0)) Q ""
NEW %1 S %1=$P(^DIC(6,P,0),"^",4)
I '%1 Q ""
Q $P($G(^DIC(7,%1,9999999)),"^",1)
;
SSN(P) ;return provider's ssn
I '$G(P) Q ""
I $P(^DD(9000010.06,.01,0),"^",2)[200 Q $P($G(^VA(200,P,1)),"^",9)
I $P(^DD(9000010.06,.01,0),"^",2)[6 Q $P($G(^DIC(16,P,0)),"^",9)
;
DMNUTR(V) ;EP - was dm nutrition educ done on this visit, Y or N
I '$G(V) Q "N"
I '$D(^AUPNVSIT(V)) Q "N"
I '$D(^AUPNVPED("AD",V)) Q "N"
NEW Y S Y=$O(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
I 'Y Q ""
NEW X,Z,R
S R=""
S X=0 F S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X S Z=$P(^AUPNVPED(X,0),"^") I $D(^ATXAX(Y,21,"B",Z)) S R=1
Q $S($G(R):"Y",1:"N")
;
LABDONE(V,T) ;EP - return Y/N
I $P($G(^BDWSITE(1,11)),U,1) Q ""
I '$G(V) Q ""
I $G(T)="" Q ""
S T=$O(^ATXLAB("B",T,0)) I 'T Q ""
NEW %,X,Y S %="N",X=0
F S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X!(%="Y") S Y=$P(^AUPNVLAB(X,0),"^") I $D(^ATXLAB(T,21,"B",Y)) S %="Y"
Q %
LABRES(V,T) ;EP - return result of lab test in taxonomy T
I $P($G(^BDWSITE(1,11)),U,1) Q ""
I '$G(V) Q ""
I $G(T)="" Q ""
S T=$O(^ATXLAB("B",T,0)) I 'T Q ""
NEW %,X,Y S %="",X=0
F S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X!(%]"") S Y=$P(^AUPNVLAB(X,0),"^") I $D(^ATXLAB(T,21,"B",Y)) S %=$P(^AUPNVLAB(X,0),"^",4)
Q %
;
LAB(RETVAL,BDWV) ;EP
I $P($G(^BDWSITE(1,11)),U,1) Q
K RETVAL
I '$G(BDWV) Q
I '$D(^AUPNVSIT(BDWV)) Q
NEW BDWI,BDWC,BDWL,BDWS,BDWLNI,BDWIENS
S (BDWI,BDWC)=0
F S BDWI=$O(^AUPNVLAB("AD",BDWV,BDWI)) Q:BDWI'=+BDWI D
.Q:'$D(^AUPNVLAB(BDWI,0))
.S BDWL=$P(^AUPNVLAB(BDWI,0),"^")
.I '$D(^LAB(60,BDWL,0)) Q
.S BDWS=$P($G(^AUPNVLAB(BDWI,11)),U,3)
.S BDWIENS=BDWS_","_BDWL_","
.S BDWLOINC=$S(BDWS]"":$$GET1^DIQ(60.01,BDWIENS,95.3),1:"")
.;ihs/cmi/maw 06/02/2014 p5 ALPMR dont screen out any lab tests
.;S BDWLOINC=$$LOINC($P(^AUPNVLAB(BDWI,0),U))
.;Q:BDWLOINC="" ;don't want that test
.S BDWC=BDWC+1
.;S RETVAL(BDWC)=$$VAL^XBDIQ1(9000010.09,BDWI,1113)_"^"_$P(^LAB(60,BDWL,0),"^")_"^"_$P(^AUPNVLAB(BDWI,0),"^",4)_"^"_$P($G(^AUPNVLAB(BDWI,11)),"^")_"^"_$P($G(^AUPNVLAB(BDWI,11)),"^",4)_"^"_$P($G(^AUPNVLAB(BDWI,11)),"^",5)
.S RETVAL(BDWC)=BDWLOINC_"^"_$P(^LAB(60,BDWL,0),"^")_"^"_$P(^AUPNVLAB(BDWI,0),"^",4)_"^"_$P($G(^AUPNVLAB(BDWI,11)),"^")_"^"_$P($G(^AUPNVLAB(BDWI,11)),"^",4)_"^"_$P($G(^AUPNVLAB(BDWI,11)),"^",5)
.Q
Q
;
LOINC(X) ;is this a test we want?
NEW T
S T=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
I T,$D(^ATXLAB(T,21,"B",X)) Q "4548-4"
S T=$O(^ATXLAB("B","BDW PAP SMEAR LAB TESTS",0))
I T,$D(^ATXLAB(T,21,"B",X)) Q "19762-4"
I $P(^LAB(60,X,0),U)="PAP SMEAR" Q "19762-4"
S T=$O(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0))
I T,$D(^ATXLAB(T,21,"B",X)) Q "2345-7"
S T=$O(^ATXLAB("B","DM AUDIT HDL TAX",0))
I T,$D(^ATXLAB(T,21,"B",X)) Q "2085-9"
S T=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
I T,$D(^ATXLAB(T,21,"B",X)) Q "2089-1"
S T=$O(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
I T,$D(^ATXLAB(T,21,"B",X)) Q "2571-8"
S T=$O(^ATXLAB("B","BDW PSA TESTS TAX",0))
I T,$D(^ATXLAB(T,21,"B",X)) Q "2857-1"
S T=$O(^ATXLAB("B","APCH FECAL OCCULT BLOOD",0))
I T,$D(^ATXLAB(T,21,"B",X)) Q "2335-8"
Q ""
FACTX(V) ;EP
NEW %,Y,Z
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q %
S Y=$P(^AUPNVINP(Z,0),"^",9)
I Y="" Q ""
I Y'["DIC(4" Q ""
S Y=+Y
I '$D(^AUTTLOC(Y,0)) Q ""
Q $P(^AUTTLOC(Y,0),"^",10)
;
BDWUTIL ; IHS/CMI/LAB - DW UTILITIES ;
+1 ;;1.0;IHS DATA WAREHOUSE;**4**;JAN 23, 2006;Build 24
+2 ;
+3 ;
POVS(RETVAL,BDWV) ;EP
+1 NEW BDWP,BDWS,BDWC,BDWY
+2 KILL RETVAL
+3 IF '$DATA(^AUPNVPOV("AD",BDWV))
QUIT
+4 SET BDWP=""
SET BDWY=0
+5 IF $PIECE(^AUPNVSIT(BDWV,0),"^",7)="H"
FOR
SET BDWY=$ORDER(^AUPNVPOV("AD",BDWV,BDWY))
IF BDWY'=+BDWY!(BDWP)
QUIT
IF $PIECE(^AUPNVPOV(BDWY,0),"^",12)="P"
SET BDWP=BDWY
+6 IF $PIECE(^AUPNVSIT(BDWV,0),"^",7)'="H"
SET BDWP=$ORDER(^AUPNVPOV("AD",BDWV,0))
+7 SET BDWC=1
+8 IF $PIECE(^AUPNVSIT(BDWV,0),U,7)="H"
IF 'BDWP
SET RETVAL(BDWC)=""
+9 ;ihs/cmi/maw 10/17/2012 patch 4 added coding system for icd10
IF BDWP
Begin DoDot:1
+10 NEW CS,ICDP,CSE,COIP,PN
+11 SET ICDP=$PIECE($GET(^AUPNVPOV(BDWP,0)),U)
+12 ;p5 ALPMR
SET PN=$TRANSLATE($$GET1^DIQ(9000010.07,BDWP,.04),"|","")
+13 IF $DATA(^ICDS(0))
SET CS=$SELECT($PIECE($$ICDDX^ICDEX(ICDP),U,20)=30:"I10",1:"I9")
+14 IF '$DATA(^ICDS(0))
SET CS="I9"
+15 SET COIP=$PIECE($GET(^AUPNVPOV(BDWP,0)),U,9)
+16 IF $GET(COIP)
Begin DoDot:2
+17 IF $DATA(^ICDS(0))
SET CSE=$SELECT($PIECE($$ICDDX^ICDEX(COIP),U,20)=30:"I10",1:"I9")
+18 IF '$DATA(^ICDS(0))
SET CSE="I9"
End DoDot:2
+19 SET RETVAL(BDWC)=$$VAL^XBDIQ1(9000010.07,BDWP,.01)_"^"_$PIECE(^AUPNVPOV(BDWP,0),"^",7)_"^"_$$VAL^XBDIQ1(9000010.07,BDWP,.09)_"^"_$PIECE(^AUPNVPOV(BDWP,0),"^",11)
+20 ;coding system
SET $PIECE(RETVAL(BDWC),"^",10)=$GET(CS)
+21 ;coding system
SET $PIECE(RETVAL(BDWC),"^",11)=$GET(CSE)
+22 ;provider narrative p5 ALPMR
SET $PIECE(RETVAL(BDWC),"^",12)=$TRANSLATE($GET(PN),"|","")
End DoDot:1
+23 SET BDWS=0
FOR
SET BDWS=$ORDER(^AUPNVPOV("AD",BDWV,BDWS))
IF BDWS'=+BDWS
QUIT
Begin DoDot:1
+24 IF BDWS=BDWP
QUIT
+25 ;ihs/cmi/maw 10/17/2012 patch 4 added coding system for icd10
+26 NEW CS,ICDP,CSE,COIP,PN
+27 SET ICDP=$PIECE($GET(^AUPNVPOV(BDWS,0)),U)
+28 ;p5 ALPMR
SET PN=$TRANSLATE($$GET1^DIQ(9000010.07,BDWS,.04),"|","")
+29 IF $DATA(^ICDS(0))
SET CS=$SELECT($PIECE($$ICDDX^ICDEX(ICDP),U,20)=30:"I10",1:"I9")
+30 IF '$DATA(^ICDS(0))
SET CS="I9"
+31 SET COIP=$PIECE($GET(^AUPNVPOV(BDWS,0)),U,9)
+32 IF $GET(COIP)
Begin DoDot:2
+33 IF $DATA(^ICDS(0))
SET CSE=$SELECT($PIECE($$ICDDX^ICDEX(COIP),U,20)=30:"I10",1:"I9")
+34 IF '$DATA(^ICDS(0))
SET CSE="I9"
End DoDot:2
+35 SET BDWC=BDWC+1
SET RETVAL(BDWC)=$$VAL^XBDIQ1(9000010.07,BDWS,.01)_"^"_$PIECE(^AUPNVPOV(BDWS,0),"^",7)_"^"_$$VAL^XBDIQ1(9000010.07,BDWS,.09)_"^"_$PIECE(^AUPNVPOV(BDWS,0),"^",11)
+36 ;coding system
SET $PIECE(RETVAL(BDWC),"^",10)=$GET(CS)
+37 ;coding system
SET $PIECE(RETVAL(BDWC),"^",11)=$GET(CSE)
+38 ;provider narrative p5 ALPMR
SET $PIECE(RETVAL(BDWC),"^",12)=$TRANSLATE($GET(PN),"|","")
End DoDot:1
+39 QUIT
DATE(D) ;EP - return YYYYMMDD from internal fm format
+1 IF $GET(D)=""
QUIT ""
+2 QUIT ($EXTRACT(D,1,3)+1700)_$EXTRACT(D,4,7)
RZERO(V,L) ;ep right zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_"0"
+3 QUIT V
LZERO(V,L) ;EP - left zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V="0"_V
+3 QUIT V
LBLK(V,L) ;left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
RBLK(V,L) ;EP right blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_" "
+3 QUIT V
+4 ;
DISPER(V) ;EP - called to get ER disposition
+1 IF '$GET(V)
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 NEW Y
SET Y=$ORDER(^AUPNVER("AD",V,0))
IF 'Y
QUIT ""
+4 QUIT $$VALI^XBDIQ1(9000010.29,Y,.11)
CPT(RETVAL,V) ;EP cpt and quantity
+1 KILL AUPNCPT,RETVAL,MOD1,MOD2
+2 NEW X,C,E
SET X=$$CPT^AUPNCPT(V)
+3 IF '$DATA(AUPNCPT)
QUIT
+4 SET (X,C)=0
FOR
SET X=$ORDER(AUPNCPT(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET C=C+1
+6 SET RETVAL(C)=$PIECE(AUPNCPT(X),"^")
+7 ;ihs/cmi/maw p5 alpmr
+8 IF $PIECE(AUPNCPT(X),"^",4)=9000010.18
Begin DoDot:2
+9 SET E=$PIECE(AUPNCPT(X),"^",5)
SET $PIECE(RETVAL(C),"^",2)=$PIECE($GET(^AUPNVCPT(E,0)),"^",16)
+10 NEW MOD1,MOD1C,MOD1I,MOD2,MOD2C,MOD2I,MOD1STR,MOD2STR
+11 SET MOD1I=$$GET1^DIQ(9000010.18,E,.08,"I")
+12 SET MOD1=$$GET1^DIQ(9000010.18,E,.08)
+13 SET MOD1C=$$GET1^DIQ(81.3,MOD1I,.02)
+14 SET MOD1STR=$SELECT(MOD1]"":MOD1_"!"_MOD1C_"!"_"CPTM",1:"")
+15 SET MOD2I=$$GET1^DIQ(9000010.18,E,.09,"I")
+16 SET MOD2=$$GET1^DIQ(9000010.18,E,.09)
+17 SET MOD2C=$$GET1^DIQ(81.3,MOD2I,.02)
+18 SET MOD2STR=$SELECT(MOD2]"":MOD2_"!"_MOD2C_"!"_"CPTM",1:"")
+19 IF $GET(MOD1STR)]""
Begin DoDot:3
+20 SET $PIECE(RETVAL(C),"^",3)=MOD1STR
+21 IF $GET(MOD2STR)]""
SET $PIECE(RETVAL(C),"^",3)=MOD1STR_"~"_MOD2STR
End DoDot:3
+22 IF $GET(MOD1STR)=""
Begin DoDot:3
+23 IF $GET(MOD2STR)]""
SET $PIECE(RETVAL(C),"^",3)=MOD2STR
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
DSCHTYPE(V) ;EP
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF $PIECE(^AUPNVSIT(V,0),"^",7)'="H"
QUIT ""
+4 NEW %,Y,Z
+5 IF $PIECE(^AUPNVSIT(V,0),"^",3)="C"
GOTO CHSDT
+6 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+7 IF 'Z
QUIT Z
+8 SET Y=$$VALI^XBDIQ1(9000010.02,Z,.06)
+9 IF 'Y
QUIT ""
+10 IF $PIECE(^DD(9000010.02,.06,0),"^",2)[42.2
QUIT $PIECE($GET(^DIC(42.2,Y,9999999)),"^")
+11 IF $PIECE(^DD(9000010.02,.06,0),"^",2)[405.1
QUIT $PIECE($GET(^DG(405.1,Y,"IHS")),"^")
+12 QUIT ""
VENTYP(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 E,T
+7 SET E=$PIECE(^AUPNVCHS(C,0),"^",14)
+8 IF 'E
QUIT ""
+9 SET T=$$VAL^XBDIQ1(9999999.11,E,1103)
+10 QUIT T
CHSDT ;
+1 SET Z=$ORDER(^AUPNVCHS("AD",V,0))
IF 'Z
QUIT ""
+2 SET Y=$$VALI^XBDIQ1(9000010.03,Z,.08)
+3 SET Y=$SELECT(Y="":"",Y=1:1,Y=2:3,Y=3:5,Y=4:7,Y=5:2,1:"")
+4 QUIT Y
DSCHDATE(V) ;EP
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF $PIECE(^AUPNVSIT(V,0),"^",7)'="H"
QUIT ""
+4 NEW Y,Z
+5 SET Z=$ORDER(^AUPNVINP("AD",V,0))
IF 'Z
GOTO CHSDD
+6 SET Y=$PIECE(^AUPNVINP(Z,0),"^")
+7 IF Y=""
QUIT Y
+8 QUIT $PIECE(Y,".")
CHSDD ;
+1 SET Z=$ORDER(^AUPNVCHS("AD",V,0))
IF 'Z
QUIT Z
+2 SET Y=$PIECE(^AUPNVCHS(Z,0),"^",7)
+3 IF Y=""
QUIT Y
+4 QUIT $PIECE(Y,".")
LOS(V) ;EP
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF $PIECE(^AUPNVSIT(V,0),"^",7)'="H"
QUIT ""
+4 NEW Y,Z,X,X1,X2
+5 IF $PIECE(^AUPNVSIT(V,0),"^",3)="C"
GOTO CHSLOS
+6 SET Z=$ORDER(^AUPNVINP("AD",V,0))
IF 'Z
QUIT ""
+7 SET X1=$PIECE($PIECE(^AUPNVINP(Z,0),"^"),".")
SET X2=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVINP(Z,0),"^",3),0),"^"),".")
DO ^%DTC
+8 IF X=0
SET X=1
+9 QUIT X
CHSLOS ;
+1 SET Z=$ORDER(^AUPNVCHS("AD",V,0))
IF 'Z
QUIT ""
+2 SET X1=$PIECE($PIECE(^AUPNVCHS(Z,0),"^",7),".")
SET X2=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVCHS(Z,0),"^",3),0),"^"),".")
DO ^%DTC
+3 IF X=0
SET X=1
+4 QUIT X
PHNAC(V) ;
+1 IF '$GET(V)
QUIT ""
+2 ;not a phn visit
IF '$$PHN(V)
QUIT ""
+3 IF $PIECE(^AUPNVSIT(V,0),"^",7)="N"
QUIT "03"
+4 IF $$CLINIC^APCLV(V,"C")=11
QUIT "01"
+5 QUIT "02"
PHN(V) ;
+1 ;is one of the providers a CHN?
+2 IF '$GET(V)
QUIT ""
+3 NEW X,%,D,N
+4 IF $$PRIMPROV^APCLV(V,"D")=13!($$PRIMPROV^APCLV(V,"D")=32)
QUIT 1
+5 SET (X,%,N)=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",V,X))
IF X'=+X
QUIT
IF $PIECE(^AUPNVPRV(X,0),"^",4)'="P"
SET N=N+1
SET D=$$SECPROV^APCLV(V,"D",N)
IF D=13!(D=32)
SET %=1
+6 QUIT %
LEVEL(V) ;EP
+1 IF '$GET(V)
QUIT ""
+2 IF '$$PHN(V)
QUIT ""
+3 NEW P
SET P=$ORDER(^AUPNVPHN("AD",V,0))
+4 IF 'P
QUIT ""
+5 QUIT $PIECE(^AUPNVPHN(P,0),"^",5)
+6 ;
MEAS(RETVAL,BDWV) ;EP -
+1 KILL RETVAL
+2 IF $PIECE($GET(^BDWSITE(1,11)),U,1)
QUIT
+3 IF '$DATA(^AUPNVSIT(BDWV))
QUIT
+4 IF '$DATA(^AUPNVMSR("AD",BDWV))
QUIT
+5 NEW BDWC,BDWI,BDWM
+6 SET (BDWI,BDWC)=0
FOR
SET BDWI=$ORDER(^AUPNVMSR("AD",BDWV,BDWI))
IF BDWI'=+BDWI
QUIT
Begin DoDot:1
+7 SET BDWM=$$VAL^XBDIQ1(9000010.01,BDWI,.01)
+8 ;ihs/cmi/maw 06/05/2014 p5 ALPMR don't screen any measurement types
+9 ;I BDWM'="BP",BDWM'="HT",BDWM'="WT" Q
+10 SET BDWVAL=$PIECE(^AUPNVMSR(BDWI,0),"^",4)
IF BDWM="HT"!(BDWM="WT")
SET BDWVAL=BDWVAL+.05
SET BDWVAL=+($PIECE(BDWVAL,".")_"."_$EXTRACT($PIECE(BDWVAL,".",2),1))
+11 SET BDWC=BDWC+1
+12 SET RETVAL(BDWC)=$PIECE(^AUTTMSR($PIECE(^AUPNVMSR(BDWI,0),"^"),0),"^",3)_"^"_BDWVAL
+13 QUIT
End DoDot:1
+14 QUIT
EXAM(RETVAL,BDWV) ;EP - return nth v exam on this visit
+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(^AUPNVXAM("AD",BDWV,BDWI))
IF BDWI'=+BDWI
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNVXAM(BDWI,0))
QUIT
+8 SET BDWE=$PIECE(^AUPNVXAM(BDWI,0),"^")
+9 IF '$DATA(^AUTTEXAM(BDWE,0))
QUIT
+10 SET BDWE=$PIECE(^AUTTEXAM(BDWE,0),"^",2)
+11 SET BDWC=BDWC+1
SET RETVAL(BDWC)=BDWE
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
PED(RETVAL,BDWV) ;EP - return nth v patient ed on this visit
+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(^AUPNVPED("AD",BDWV,BDWI))
IF BDWI'=+BDWI
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNVPED(BDWI,0))
QUIT
+8 SET BDWE=$PIECE(^AUPNVPED(BDWI,0),"^")
+9 IF '$DATA(^AUTTEDT(BDWE,0))
QUIT
+10 SET BDWE=$PIECE(^AUTTEDT(BDWE,0),"^",2)
+11 SET BDWC=BDWC+1
SET RETVAL(BDWC)=BDWE
+12 IF $PIECE($GET(^BDWSITE(1,11)),U,1)
QUIT
+13 SET RETVAL(BDWC)=RETVAL(BDWC)_"^"_$PIECE(^AUPNVPED(BDWI,0),"^",6)_"^"_$PIECE(^AUPNVPED(BDWI,0),"^",8)
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
DENTCOST(V) ;COST OF THIS VISIT
+1 IF '$GET(V)
QUIT ""
+2 NEW X,Y,C
+3 SET X=0
SET C=""
+4 FOR
SET X=$ORDER(^AUPNVDEN("AD",V,X))
IF X'=+X
QUIT
SET C=C+$PIECE(^AUPNVDEN(X,0),U,7)
+5 QUIT $SELECT(C=0:"",1:$PIECE((C+.5),"."))
DENT(RETVAL,BDWV) ;EP
+1 IF '$GET(BDWV)
QUIT
+2 IF '$DATA(^AUPNVSIT(BDWV))
QUIT
+3 KILL RETVAL
+4 NEW BDWI,BDWC
+5 SET (BDWI,BDWC)=0
+6 FOR
SET BDWI=$ORDER(^AUPNVDEN("AD",BDWV,BDWI))
IF BDWI'=+BDWI
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNVDEN(BDWI,0))
QUIT
+8 SET BDWC=BDWC+1
+9 SET RETVAL(BDWC)=$$VAL^XBDIQ1(9000010.05,BDWI,.01)_"^"_$PIECE(^AUPNVDEN(BDWI,0),"^",4)_"^"_$PIECE(^AUPNVDEN(BDWI,0),"^",7)_"^"_$SELECT($PIECE(^AUPNVSIT(BDWV,0),"^",3)="C":"K",1:"D")
+10 SET $PIECE(RETVAL(BDWC),"^",5)=$$DENTSSN(BDWV)
+11 IF $PIECE(^AUPNVDEN(BDWI,0),"^",5)]""
SET $PIECE(RETVAL(BDWC),"^",6)=$$VAL^XBDIQ1(9002010.03,$PIECE(^AUPNVDEN(BDWI,0),"^",5),8801)
+12 SET $PIECE(RETVAL(BDWC),"^",7)=$PIECE(^AUPNVDEN(BDWI,0),"^",6)
+13 IF BDWC=1
SET $PIECE(RETVAL(BDWC,0),"^",8)=$$DENTCOST(BDWV)
End DoDot:1
+14 QUIT
DENTSSN(V) ;EP - if a provider is a 52 get SSN
+1 IF '$GET(V)
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 NEW X,Y,S
SET S=""
SET X=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",V,X))
IF X'=+X!(S]"")
QUIT
SET Y=$PIECE(^AUPNVPRV(X,0),"^")
Begin DoDot:1
+4 SET D=$$CLS(Y)
+5 IF D=52
SET S=$$SSN(Y)
+6 QUIT
End DoDot:1
+7 QUIT S
CLS(P) ;return ihs class code for provider P
+1 IF '$GET(P)
QUIT ""
+2 NEW %
SET %=""
+3 IF $PIECE(^DD(9000010.06,.01,0),"^",2)[200
Begin DoDot:1
+4 IF '$DATA(^VA(200,P))
QUIT
+5 NEW %1
SET %1=$PIECE($GET(^VA(200,P,"PS")),"^",5)
+6 IF '%1
QUIT
+7 SET %=$PIECE($GET(^DIC(7,%1,9999999)),"^")
+8 QUIT
End DoDot:1
QUIT %
+9 IF '$DATA(^DIC(6,P,0))
QUIT ""
+10 NEW %1
SET %1=$PIECE(^DIC(6,P,0),"^",4)
+11 IF '%1
QUIT ""
+12 QUIT $PIECE($GET(^DIC(7,%1,9999999)),"^",1)
+13 ;
SSN(P) ;return provider's ssn
+1 IF '$GET(P)
QUIT ""
+2 IF $PIECE(^DD(9000010.06,.01,0),"^",2)[200
QUIT $PIECE($GET(^VA(200,P,1)),"^",9)
+3 IF $PIECE(^DD(9000010.06,.01,0),"^",2)[6
QUIT $PIECE($GET(^DIC(16,P,0)),"^",9)
+4 ;
DMNUTR(V) ;EP - was dm nutrition educ done on this visit, Y or N
+1 IF '$GET(V)
QUIT "N"
+2 IF '$DATA(^AUPNVSIT(V))
QUIT "N"
+3 IF '$DATA(^AUPNVPED("AD",V))
QUIT "N"
+4 NEW Y
SET Y=$ORDER(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
+5 IF 'Y
QUIT ""
+6 NEW X,Z,R
+7 SET R=""
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",V,X))
IF X'=+X
QUIT
SET Z=$PIECE(^AUPNVPED(X,0),"^")
IF $DATA(^ATXAX(Y,21,"B",Z))
SET R=1
+9 QUIT $SELECT($GET(R):"Y",1:"N")
+10 ;
LABDONE(V,T) ;EP - return Y/N
+1 IF $PIECE($GET(^BDWSITE(1,11)),U,1)
QUIT ""
+2 IF '$GET(V)
QUIT ""
+3 IF $GET(T)=""
QUIT ""
+4 SET T=$ORDER(^ATXLAB("B",T,0))
IF 'T
QUIT ""
+5 NEW %,X,Y
SET %="N"
SET X=0
+6 FOR
SET X=$ORDER(^AUPNVLAB("AD",V,X))
IF X'=+X!(%="Y")
QUIT
SET Y=$PIECE(^AUPNVLAB(X,0),"^")
IF $DATA(^ATXLAB(T,21,"B",Y))
SET %="Y"
+7 QUIT %
LABRES(V,T) ;EP - return result of lab test in taxonomy T
+1 IF $PIECE($GET(^BDWSITE(1,11)),U,1)
QUIT ""
+2 IF '$GET(V)
QUIT ""
+3 IF $GET(T)=""
QUIT ""
+4 SET T=$ORDER(^ATXLAB("B",T,0))
IF 'T
QUIT ""
+5 NEW %,X,Y
SET %=""
SET X=0
+6 FOR
SET X=$ORDER(^AUPNVLAB("AD",V,X))
IF X'=+X!(%]"")
QUIT
SET Y=$PIECE(^AUPNVLAB(X,0),"^")
IF $DATA(^ATXLAB(T,21,"B",Y))
SET %=$PIECE(^AUPNVLAB(X,0),"^",4)
+7 QUIT %
+8 ;
LAB(RETVAL,BDWV) ;EP
+1 IF $PIECE($GET(^BDWSITE(1,11)),U,1)
QUIT
+2 KILL RETVAL
+3 IF '$GET(BDWV)
QUIT
+4 IF '$DATA(^AUPNVSIT(BDWV))
QUIT
+5 NEW BDWI,BDWC,BDWL,BDWS,BDWLNI,BDWIENS
+6 SET (BDWI,BDWC)=0
+7 FOR
SET BDWI=$ORDER(^AUPNVLAB("AD",BDWV,BDWI))
IF BDWI'=+BDWI
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNVLAB(BDWI,0))
QUIT
+9 SET BDWL=$PIECE(^AUPNVLAB(BDWI,0),"^")
+10 IF '$DATA(^LAB(60,BDWL,0))
QUIT
+11 SET BDWS=$PIECE($GET(^AUPNVLAB(BDWI,11)),U,3)
+12 SET BDWIENS=BDWS_","_BDWL_","
+13 SET BDWLOINC=$SELECT(BDWS]"":$$GET1^DIQ(60.01,BDWIENS,95.3),1:"")
+14 ;ihs/cmi/maw 06/02/2014 p5 ALPMR dont screen out any lab tests
+15 ;S BDWLOINC=$$LOINC($P(^AUPNVLAB(BDWI,0),U))
+16 ;Q:BDWLOINC="" ;don't want that test
+17 SET BDWC=BDWC+1
+18 ;S RETVAL(BDWC)=$$VAL^XBDIQ1(9000010.09,BDWI,1113)_"^"_$P(^LAB(60,BDWL,0),"^")_"^"_$P(^AUPNVLAB(BDWI,0),"^",4)_"^"_$P($G(^AUPNVLAB(BDWI,11)),"^")_"^"_$P($G(^AUPNVLAB(BDWI,11)),"^",4)_"^"_$P($G(^AUPNVLAB(BDWI,11)),"^",5)
+19 SET RETVAL(BDWC)=BDWLOINC_"^"_$PIECE(^LAB(60,BDWL,0),"^")_"^"_$PIECE(^AUPNVLAB(BDWI,0),"^",4)_"^"_$PIECE($GET(^AUPNVLAB(BDWI,11)),"^")_"^"_$PIECE($GET(^AUPNVLAB(BDWI,11)),"^",4)_"^"_$PIECE($GET(^AUPNVLAB(BDWI,11)),"^",5)
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
LOINC(X) ;is this a test we want?
+1 NEW T
+2 SET T=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
+3 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
QUIT "4548-4"
+4 SET T=$ORDER(^ATXLAB("B","BDW PAP SMEAR LAB TESTS",0))
+5 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
QUIT "19762-4"
+6 IF $PIECE(^LAB(60,X,0),U)="PAP SMEAR"
QUIT "19762-4"
+7 SET T=$ORDER(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0))
+8 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
QUIT "2345-7"
+9 SET T=$ORDER(^ATXLAB("B","DM AUDIT HDL TAX",0))
+10 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
QUIT "2085-9"
+11 SET T=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
+12 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
QUIT "2089-1"
+13 SET T=$ORDER(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
+14 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
QUIT "2571-8"
+15 SET T=$ORDER(^ATXLAB("B","BDW PSA TESTS TAX",0))
+16 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
QUIT "2857-1"
+17 SET T=$ORDER(^ATXLAB("B","APCH FECAL OCCULT BLOOD",0))
+18 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
QUIT "2335-8"
+19 QUIT ""
FACTX(V) ;EP
+1 NEW %,Y,Z
+2 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+3 IF 'Z
QUIT %
+4 SET Y=$PIECE(^AUPNVINP(Z,0),"^",9)
+5 IF Y=""
QUIT ""
+6 IF Y'["DIC(4"
QUIT ""
+7 SET Y=+Y
+8 IF '$DATA(^AUTTLOC(Y,0))
QUIT ""
+9 QUIT $PIECE(^AUTTLOC(Y,0),"^",10)
+10 ;
