APCPUTIL ; IHS/TUCSON/LAB - DW UTILITIES ; [ 08/18/2003 7:44 AM ]
;;2.0;IHS PCC DATA EXTRACTION;**6**;APR 03, 1998
;
;
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
;
CPTRECS(V) ;EP # of cpt records (AD4's)
K AUPNCPT
NEW X,C,R S X=$$CPT^AUPNCPT(V)
I '$D(AUPNCPT) Q 0
S (X,C)=0 F S X=$O(AUPNCPT(X)) Q:X'=+X S C=C+1
S R=$S(C#25=0:C/25,1:(C\25)+1) ;IHS/CMI/LAB
Q R
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 $$DATE($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 $$DATE($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(V,T,F) ;EP - return first weight recorded
;F=1 returns value as is, otherwise truncate and round to 2 digits
;V is visit ien T is measurement type
I '$D(^AUPNVSIT(V)) Q ""
I $G(T)="" Q ""
I '$D(^AUPNVMSR("AD",V)) Q ""
NEW Y S Y=$O(^AUTTMSR("B",T,0))
I 'Y Q ""
S F=$G(F)
NEW X,Z,R S R=""
S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X I $P(^AUPNVMSR(X,0),"^")=Y S R=$P(^AUPNVMSR(X,0),"^",4)
I R="" Q R
I $G(F)=1 Q R
S R=R+.05 Q +($P(R,".")_"."_$E($P(R,".",2),1))
EXAM(V,N) ;EP - return nth v exam on this visit
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I '$G(N) Q ""
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
S Y=0 F S Y=$O(^AUPNVXAM("AD",V,Y)) Q:Y'=+Y S C=C+1 I C=N S P=$P(^AUPNVXAM(Y,0),"^"),Z=Y
I 'P Q P
I '$D(^AUTTEXAM(P)) Q ""
Q $P(^AUTTEXAM(P,0),"^",2)
;
PED(V,N) ;EP - return nth v patient ed on this visit
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I '$G(N) Q ""
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
S Y=0 F S Y=$O(^AUPNVPED("AD",V,Y)) Q:Y'=+Y S C=C+1 I C=N S P=$P(^AUPNVPED(Y,0),"^"),Z=Y
I 'P Q P
I '$D(^AUTTEDT(P)) Q ""
Q $P(^AUTTEDT(P,0),"^",2)
;
IMM(V,F,N) ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
I '$G(N) Q -1
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
S Y=0 F S Y=$O(^AUPNVIMM("AD",V,Y)) Q:Y'=+Y S C=C+1 I C=N S P=$P(^AUPNVIMM(Y,0),"^"),Z=Y
I 'P Q P
I '$D(^AUTTIMM(P)) Q -1
I $G(F)="" S F="C"
S %="" D @F
Q %
;
I ;
S %=P Q
E ;
S %=$P(^AUTTIMM(P,0),"^") Q
S ;
S %=$P(^AUPNVIMM(Z,0),"^",4) Q
C ;
;IHS/CMI/LAB - modified line below for patch 4 1/5/1999
S %=$P(^AUTTIMM(P,0),"^",$S($$BI:20,1:3)) Q
;
H ;
I '$$BI S %="" Q
S %=$P(^AUTTIMM(P,0),"^",3)
Q
BI() ;IHS/CMI/LAB - new subroutine patch 4 1/5/1999
Q $S($O(^AUTTIMM(0))<100:0,1:1)
;
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)
;
NATION(V) ;EP
I '$G(V) Q ""
NEW P S P=$P(^AUPNVSIT(V,0),"^",5)
I 'P Q ""
Q $S($$BEN^AUPNPAT(P,"C")="01":"I",$$BEN^AUPNPAT(P,"C")="":"I",1:"O")
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),"."))
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),U) I $D(^ATXAX(Y,21,"B",Z)) S R=1
Q $S($G(R):"Y",1:"N")
;
ZIP(V) ;EP - zip code of patient
I '$G(V) Q ""
NEW P S P=$P(^AUPNVSIT(V,0),U,5)
Q $P($G(^DPT(P,.11)),U,6)
PAP(V) ;EP - was pap performed Y/N
I '$G(V) Q ""
NEW T S T=$O(^ATXLAB("B","APCP 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 ""
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 $E(Y,1,15) ;**********
LABDONE(V,T) ;EP - return Y/N
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),U) I $D(^ATXLAB(T,21,"B",Y)) S %="Y"
Q %
LABRES(V,T) ;EP - return result of lab test in taxonomy T
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),U) I $D(^ATXLAB(T,21,"B",Y)) S %=$P(^AUPNVLAB(X,0),U,4)
Q $E(%,1,15) ;**********
HF(V,F) ;EP was this health factor recorded on this visit
I '$G(V) Q ""
NEW T S T=$O(^AUTTHF("B",F,0)) I 'T Q ""
NEW X,Y S X=0,Y="N" F S X=$O(^AUPNVHF("AD",V,X)) Q:X'=+X!(Y="Y") I $P(^AUPNVHF(X,0),U)=T S Y="Y"
Q Y
HFNAME(V,C) ;EP return name of health factor in this category
I '$G(V) Q ""
S C=$O(^AUTTHF("B",C,0)) I 'C Q ""
NEW X,Y,Z S Y="",X=0 F S X=$O(^AUPNVHF("AD",V,X)) Q:X'=+X!(Y]"") S Z=$P(^AUPNVHF(X,0),U) I $P(^AUTTHF(Z,0),U,3)=C S Y=$P(^AUTTHF(Z,0),U)
Q Y
DELM(V) ;
NEW S
I '$G(V) Q ""
S S=$S($P(^AUPNVSIT(V,0),U,7)="C":"K",1:"D")
I $$CLINIC^APCLV(APCPVIEN,"C")=56 Q S
I $$CLINIC^APCLV(APCPVIEN,"C")=99 Q S
I $D(^AUPNVDEN("AD",APCPVIEN)) Q S
Q ""
UPI(V) ;EP unique Patient ID
I '$G(V) Q ""
NEW P S P=$P(^AUPNVSIT(V,0),U,5)
I 'P Q ""
I '$P($G(^AUTTSITE(1,1)),U,3) S $P(^AUTTSITE(1,1),U,3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0),U,10)
;
Q $P(^AUTTSITE(1,1),U,3)_$E("0000000000",1,10-$L(P))_P
APCPUTIL ; IHS/TUCSON/LAB - DW UTILITIES ; [ 08/18/2003 7:44 AM ]
+1 ;;2.0;IHS PCC DATA EXTRACTION;**6**;APR 03, 1998
+2 ;
+3 ;
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 ;
CPTRECS(V) ;EP # of cpt records (AD4's)
+1 KILL AUPNCPT
+2 NEW X,C,R
SET X=$$CPT^AUPNCPT(V)
+3 IF '$DATA(AUPNCPT)
QUIT 0
+4 SET (X,C)=0
FOR
SET X=$ORDER(AUPNCPT(X))
IF X'=+X
QUIT
SET C=C+1
+5 ;IHS/CMI/LAB
SET R=$SELECT(C#25=0:C/25,1:(C\25)+1)
+6 QUIT R
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 $$DATE($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 $$DATE($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(V,T,F) ;EP - return first weight recorded
+1 ;F=1 returns value as is, otherwise truncate and round to 2 digits
+2 ;V is visit ien T is measurement type
+3 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+4 IF $GET(T)=""
QUIT ""
+5 IF '$DATA(^AUPNVMSR("AD",V))
QUIT ""
+6 NEW Y
SET Y=$ORDER(^AUTTMSR("B",T,0))
+7 IF 'Y
QUIT ""
+8 SET F=$GET(F)
+9 NEW X,Z,R
SET R=""
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
IF $PIECE(^AUPNVMSR(X,0),"^")=Y
SET R=$PIECE(^AUPNVMSR(X,0),"^",4)
+11 IF R=""
QUIT R
+12 IF $GET(F)=1
QUIT R
+13 SET R=R+.05
QUIT +($PIECE(R,".")_"."_$EXTRACT($PIECE(R,".",2),1))
EXAM(V,N) ;EP - return nth v exam on this visit
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF '$GET(N)
QUIT ""
+4 NEW %,Y,P,C,Z
+5 SET (Z,P)=""
SET (Y,C)=0
+6 SET Y=0
FOR
SET Y=$ORDER(^AUPNVXAM("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C=N
SET P=$PIECE(^AUPNVXAM(Y,0),"^")
SET Z=Y
+7 IF 'P
QUIT P
+8 IF '$DATA(^AUTTEXAM(P))
QUIT ""
+9 QUIT $PIECE(^AUTTEXAM(P,0),"^",2)
+10 ;
PED(V,N) ;EP - return nth v patient ed on this visit
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF '$GET(N)
QUIT ""
+4 NEW %,Y,P,C,Z
+5 SET (Z,P)=""
SET (Y,C)=0
+6 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPED("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C=N
SET P=$PIECE(^AUPNVPED(Y,0),"^")
SET Z=Y
+7 IF 'P
QUIT P
+8 IF '$DATA(^AUTTEDT(P))
QUIT ""
+9 QUIT $PIECE(^AUTTEDT(P,0),"^",2)
+10 ;
IMM(V,F,N) ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 IF '$GET(N)
QUIT -1
+4 NEW %,Y,P,C,Z
+5 SET (Z,P)=""
SET (Y,C)=0
+6 SET Y=0
FOR
SET Y=$ORDER(^AUPNVIMM("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C=N
SET P=$PIECE(^AUPNVIMM(Y,0),"^")
SET Z=Y
+7 IF 'P
QUIT P
+8 IF '$DATA(^AUTTIMM(P))
QUIT -1
+9 IF $GET(F)=""
SET F="C"
+10 SET %=""
DO @F
+11 QUIT %
+12 ;
I ;
+1 SET %=P
QUIT
E ;
+1 SET %=$PIECE(^AUTTIMM(P,0),"^")
QUIT
S ;
+1 SET %=$PIECE(^AUPNVIMM(Z,0),"^",4)
QUIT
C ;
+1 ;IHS/CMI/LAB - modified line below for patch 4 1/5/1999
+2 SET %=$PIECE(^AUTTIMM(P,0),"^",$SELECT($$BI:20,1:3))
QUIT
+3 ;
H ;
+1 IF '$$BI
SET %=""
QUIT
+2 SET %=$PIECE(^AUTTIMM(P,0),"^",3)
+3 QUIT
BI() ;IHS/CMI/LAB - new subroutine patch 4 1/5/1999
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))<100:0,1:1)
+2 ;
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 ;
NATION(V) ;EP
+1 IF '$GET(V)
QUIT ""
+2 NEW P
SET P=$PIECE(^AUPNVSIT(V,0),"^",5)
+3 IF 'P
QUIT ""
+4 QUIT $SELECT($$BEN^AUPNPAT(P,"C")="01":"I",$$BEN^AUPNPAT(P,"C")="":"I",1:"O")
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),"."))
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),U)
IF $DATA(^ATXAX(Y,21,"B",Z))
SET R=1
+9 QUIT $SELECT($GET(R):"Y",1:"N")
+10 ;
ZIP(V) ;EP - zip code of patient
+1 IF '$GET(V)
QUIT ""
+2 NEW P
SET P=$PIECE(^AUPNVSIT(V,0),U,5)
+3 QUIT $PIECE($GET(^DPT(P,.11)),U,6)
PAP(V) ;EP - was pap performed Y/N
+1 IF '$GET(V)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","APCP PAP SMEAR LAB TESTS",0))
+3 IF 'T
QUIT ""
+4 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"
+5 QUIT Y
GLUCOSE(V) ;EP - return glucose test value on this visit
+1 IF '$GET(V)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0))
+3 IF 'T
QUIT ""
+4 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)
+5 ;**********
QUIT $EXTRACT(Y,1,15)
LABDONE(V,T) ;EP - return Y/N
+1 IF '$GET(V)
QUIT ""
+2 IF $GET(T)=""
QUIT ""
+3 SET T=$ORDER(^ATXLAB("B",T,0))
IF 'T
QUIT ""
+4 NEW %,X,Y
SET %="N"
SET X=0
+5 FOR
SET X=$ORDER(^AUPNVLAB("AD",V,X))
IF X'=+X!(%="Y")
QUIT
SET Y=$PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(T,21,"B",Y))
SET %="Y"
+6 QUIT %
LABRES(V,T) ;EP - return result of lab test in taxonomy T
+1 IF '$GET(V)
QUIT ""
+2 IF $GET(T)=""
QUIT ""
+3 SET T=$ORDER(^ATXLAB("B",T,0))
IF 'T
QUIT ""
+4 NEW %,X,Y
SET %=""
SET X=0
+5 FOR
SET X=$ORDER(^AUPNVLAB("AD",V,X))
IF X'=+X!(%]"")
QUIT
SET Y=$PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(T,21,"B",Y))
SET %=$PIECE(^AUPNVLAB(X,0),U,4)
+6 ;**********
QUIT $EXTRACT(%,1,15)
HF(V,F) ;EP was this health factor recorded on this visit
+1 IF '$GET(V)
QUIT ""
+2 NEW T
SET T=$ORDER(^AUTTHF("B",F,0))
IF 'T
QUIT ""
+3 NEW X,Y
SET X=0
SET Y="N"
FOR
SET X=$ORDER(^AUPNVHF("AD",V,X))
IF X'=+X!(Y="Y")
QUIT
IF $PIECE(^AUPNVHF(X,0),U)=T
SET Y="Y"
+4 QUIT Y
HFNAME(V,C) ;EP return name of health factor in this category
+1 IF '$GET(V)
QUIT ""
+2 SET C=$ORDER(^AUTTHF("B",C,0))
IF 'C
QUIT ""
+3 NEW X,Y,Z
SET Y=""
SET X=0
FOR
SET X=$ORDER(^AUPNVHF("AD",V,X))
IF X'=+X!(Y]"")
QUIT
SET Z=$PIECE(^AUPNVHF(X,0),U)
IF $PIECE(^AUTTHF(Z,0),U,3)=C
SET Y=$PIECE(^AUTTHF(Z,0),U)
+4 QUIT Y
DELM(V) ;
+1 NEW S
+2 IF '$GET(V)
QUIT ""
+3 SET S=$SELECT($PIECE(^AUPNVSIT(V,0),U,7)="C":"K",1:"D")
+4 IF $$CLINIC^APCLV(APCPVIEN,"C")=56
QUIT S
+5 IF $$CLINIC^APCLV(APCPVIEN,"C")=99
QUIT S
+6 IF $DATA(^AUPNVDEN("AD",APCPVIEN))
QUIT S
+7 QUIT ""
UPI(V) ;EP unique Patient ID
+1 IF '$GET(V)
QUIT ""
+2 NEW P
SET P=$PIECE(^AUPNVSIT(V,0),U,5)
+3 IF 'P
QUIT ""
+4 IF '$PIECE($GET(^AUTTSITE(1,1)),U,3)
SET $PIECE(^AUTTSITE(1,1),U,3)=$PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U,1),0),U,10)
+5 ;
+6 QUIT $PIECE(^AUTTSITE(1,1),U,3)_$EXTRACT("0000000000",1,10-$LENGTH(P))_P
