Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCPUTIL

APCPUTIL.m

Go to the documentation of this file.
  1. APCPUTIL ; IHS/TUCSON/LAB - DW UTILITIES ; [ 08/18/2003 7:44 AM ]
  1. ;;2.0;IHS PCC DATA EXTRACTION;**6**;APR 03, 1998
  1. ;
  1. ;
  1. DATE(D) ;EP - return YYYYMMDD from internal fm format
  1. I $G(D)="" Q ""
  1. Q ($E(D,1,3)+1700)_$E(D,4,7)
  1. RZERO(V,L) ;ep right zero fill
  1. NEW %,I
  1. S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"
  1. Q V
  1. LZERO(V,L) ;EP - left zero fill
  1. NEW %,I
  1. S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
  1. Q V
  1. LBLK(V,L) ;left blank fill
  1. NEW %,I
  1. S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
  1. Q V
  1. RBLK(V,L) ;EP right blank fill
  1. NEW %,I
  1. S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "
  1. Q V
  1. ;
  1. CPTRECS(V) ;EP # of cpt records (AD4's)
  1. K AUPNCPT
  1. NEW X,C,R S X=$$CPT^AUPNCPT(V)
  1. I '$D(AUPNCPT) Q 0
  1. S (X,C)=0 F S X=$O(AUPNCPT(X)) Q:X'=+X S C=C+1
  1. S R=$S(C#25=0:C/25,1:(C\25)+1) ;IHS/CMI/LAB
  1. Q R
  1. DSCHTYPE(V) ;EP
  1. I 'V Q ""
  1. I '$D(^AUPNVSIT(V)) Q ""
  1. I $P(^AUPNVSIT(V,0),"^",7)'="H" Q ""
  1. NEW %,Y,Z
  1. I $P(^AUPNVSIT(V,0),"^",3)="C" G CHSDT
  1. S %="",Z=$O(^AUPNVINP("AD",V,0))
  1. I 'Z Q Z
  1. S Y=$$VALI^XBDIQ1(9000010.02,Z,.06)
  1. I 'Y Q ""
  1. I $P(^DD(9000010.02,.06,0),"^",2)[42.2 Q $P($G(^DIC(42.2,Y,9999999)),"^")
  1. I $P(^DD(9000010.02,.06,0),"^",2)[405.1 Q $P($G(^DG(405.1,Y,"IHS")),"^")
  1. Q ""
  1. VENTYP(V) ;EP return vendor type from VCHS
  1. I '$G(V) Q ""
  1. I '$D(^AUPNVSIT(V)) Q ""
  1. NEW C S C=$O(^AUPNVCHS("AD",V,0))
  1. I 'C Q ""
  1. I '$D(^AUPNVCHS(C,0)) Q ""
  1. NEW E,T
  1. S E=$P(^AUPNVCHS(C,0),"^",14)
  1. I 'E Q ""
  1. S T=$$VAL^XBDIQ1(9999999.11,E,1103)
  1. Q T
  1. CHSDT ;
  1. S Z=$O(^AUPNVCHS("AD",V,0)) I 'Z Q ""
  1. S Y=$$VALI^XBDIQ1(9000010.03,Z,.08)
  1. S Y=$S(Y="":"",Y=1:1,Y=2:3,Y=3:5,Y=4:7,Y=5:2,1:"")
  1. Q Y
  1. DSCHDATE(V) ;EP
  1. I 'V Q ""
  1. I '$D(^AUPNVSIT(V)) Q ""
  1. I $P(^AUPNVSIT(V,0),"^",7)'="H" Q ""
  1. NEW Y,Z
  1. S Z=$O(^AUPNVINP("AD",V,0)) I 'Z G CHSDD
  1. S Y=$P(^AUPNVINP(Z,0),"^")
  1. I Y="" Q Y
  1. Q $$DATE($P(Y,"."))
  1. CHSDD ;
  1. S Z=$O(^AUPNVCHS("AD",V,0)) I 'Z Q Z
  1. S Y=$P(^AUPNVCHS(Z,0),"^",7)
  1. I Y="" Q Y
  1. Q $$DATE($P(Y,"."))
  1. LOS(V) ;EP
  1. I 'V Q ""
  1. I '$D(^AUPNVSIT(V)) Q ""
  1. I $P(^AUPNVSIT(V,0),"^",7)'="H" Q ""
  1. NEW Y,Z,X,X1,X2
  1. I $P(^AUPNVSIT(V,0),"^",3)="C" G CHSLOS
  1. S Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q ""
  1. S X1=$P($P(^AUPNVINP(Z,0),"^"),"."),X2=$P($P(^AUPNVSIT($P(^AUPNVINP(Z,0),"^",3),0),"^"),".") D ^%DTC
  1. S:X=0 X=1
  1. Q X
  1. CHSLOS ;
  1. S Z=$O(^AUPNVCHS("AD",V,0)) I 'Z Q ""
  1. S X1=$P($P(^AUPNVCHS(Z,0),"^",7),"."),X2=$P($P(^AUPNVSIT($P(^AUPNVCHS(Z,0),"^",3),0),"^"),".") D ^%DTC
  1. S:X=0 X=1
  1. Q X
  1. PHNAC(V) ;
  1. I '$G(V) Q ""
  1. I '$$PHN(V) Q "" ;not a phn visit
  1. I $P(^AUPNVSIT(V,0),"^",7)="N" Q "03"
  1. I $$CLINIC^APCLV(V,"C")=11 Q "01"
  1. Q "02"
  1. PHN(V) ;
  1. ;is one of the providers a CHN?
  1. I '$G(V) Q ""
  1. NEW X,%,D,N
  1. I $$PRIMPROV^APCLV(V,"D")=13!($$PRIMPROV^APCLV(V,"D")=32) Q 1
  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
  1. Q %
  1. LEVEL(V) ;EP
  1. I '$G(V) Q ""
  1. I '$$PHN(V) Q ""
  1. NEW P S P=$O(^AUPNVPHN("AD",V,0))
  1. I 'P Q ""
  1. Q $P(^AUPNVPHN(P,0),"^",5)
  1. ;
  1. MEAS(V,T,F) ;EP - return first weight recorded
  1. ;F=1 returns value as is, otherwise truncate and round to 2 digits
  1. ;V is visit ien T is measurement type
  1. I '$D(^AUPNVSIT(V)) Q ""
  1. I $G(T)="" Q ""
  1. I '$D(^AUPNVMSR("AD",V)) Q ""
  1. NEW Y S Y=$O(^AUTTMSR("B",T,0))
  1. I 'Y Q ""
  1. S F=$G(F)
  1. NEW X,Z,R S R=""
  1. 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)
  1. I R="" Q R
  1. I $G(F)=1 Q R
  1. S R=R+.05 Q +($P(R,".")_"."_$E($P(R,".",2),1))
  1. EXAM(V,N) ;EP - return nth v exam on this visit
  1. I 'V Q ""
  1. I '$D(^AUPNVSIT(V)) Q ""
  1. I '$G(N) Q ""
  1. NEW %,Y,P,C,Z
  1. S (Z,P)="",(Y,C)=0
  1. 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
  1. I 'P Q P
  1. I '$D(^AUTTEXAM(P)) Q ""
  1. Q $P(^AUTTEXAM(P,0),"^",2)
  1. ;
  1. PED(V,N) ;EP - return nth v patient ed on this visit
  1. I 'V Q ""
  1. I '$D(^AUPNVSIT(V)) Q ""
  1. I '$G(N) Q ""
  1. NEW %,Y,P,C,Z
  1. S (Z,P)="",(Y,C)=0
  1. 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
  1. I 'P Q P
  1. I '$D(^AUTTEDT(P)) Q ""
  1. Q $P(^AUTTEDT(P,0),"^",2)
  1. ;
  1. IMM(V,F,N) ;EP
  1. I 'V Q -1
  1. I '$D(^AUPNVSIT(V)) Q -1
  1. I '$G(N) Q -1
  1. NEW %,Y,P,C,Z
  1. S (Z,P)="",(Y,C)=0
  1. 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
  1. I 'P Q P
  1. I '$D(^AUTTIMM(P)) Q -1
  1. I $G(F)="" S F="C"
  1. S %="" D @F
  1. Q %
  1. ;
  1. I ;
  1. S %=P Q
  1. E ;
  1. S %=$P(^AUTTIMM(P,0),"^") Q
  1. S ;
  1. S %=$P(^AUPNVIMM(Z,0),"^",4) Q
  1. C ;
  1. ;IHS/CMI/LAB - modified line below for patch 4 1/5/1999
  1. S %=$P(^AUTTIMM(P,0),"^",$S($$BI:20,1:3)) Q
  1. ;
  1. H ;
  1. I '$$BI S %="" Q
  1. S %=$P(^AUTTIMM(P,0),"^",3)
  1. Q
  1. BI() ;IHS/CMI/LAB - new subroutine patch 4 1/5/1999
  1. Q $S($O(^AUTTIMM(0))<100:0,1:1)
  1. ;
  1. DENTSSN(V) ;EP - if a provider is a 52 get SSN
  1. I '$G(V) Q ""
  1. I '$D(^AUPNVSIT(V)) Q ""
  1. 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
  1. .S D=$$CLS(Y)
  1. .I D=52 S S=$$SSN(Y)
  1. .Q
  1. Q S
  1. CLS(P) ;return ihs class code for provider P
  1. I '$G(P) Q ""
  1. NEW % S %=""
  1. I $P(^DD(9000010.06,.01,0),"^",2)[200 D Q %
  1. .Q:'$D(^VA(200,P))
  1. .NEW %1 S %1=$P($G(^VA(200,P,"PS")),"^",5)
  1. .I '%1 Q
  1. .S %=$P($G(^DIC(7,%1,9999999)),"^")
  1. .Q
  1. I '$D(^DIC(6,P,0)) Q ""
  1. NEW %1 S %1=$P(^DIC(6,P,0),"^",4)
  1. I '%1 Q ""
  1. Q $P($G(^DIC(7,%1,9999999)),"^",1)
  1. ;
  1. SSN(P) ;return provider's ssn
  1. I '$G(P) Q ""
  1. I $P(^DD(9000010.06,.01,0),"^",2)[200 Q $P($G(^VA(200,P,1)),"^",9)
  1. I $P(^DD(9000010.06,.01,0),"^",2)[6 Q $P($G(^DIC(16,P,0)),"^",9)
  1. ;
  1. NATION(V) ;EP
  1. I '$G(V) Q ""
  1. NEW P S P=$P(^AUPNVSIT(V,0),"^",5)
  1. I 'P Q ""
  1. Q $S($$BEN^AUPNPAT(P,"C")="01":"I",$$BEN^AUPNPAT(P,"C")="":"I",1:"O")
  1. DENTCOST(V) ;COST OF THIS VISIT
  1. I '$G(V) Q ""
  1. NEW X,Y,C
  1. S X=0,C=""
  1. F S X=$O(^AUPNVDEN("AD",V,X)) Q:X'=+X S C=C+$P(^AUPNVDEN(X,0),U,7)
  1. Q $S(C=0:"",1:$P((C+.5),"."))
  1. DMNUTR(V) ;EP - was dm nutrition educ done on this visit, Y or N
  1. I '$G(V) Q "N"
  1. I '$D(^AUPNVSIT(V)) Q "N"
  1. I '$D(^AUPNVPED("AD",V)) Q "N"
  1. NEW Y S Y=$O(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
  1. I 'Y Q ""
  1. NEW X,Z,R
  1. S R=""
  1. 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
  1. Q $S($G(R):"Y",1:"N")
  1. ;
  1. ZIP(V) ;EP - zip code of patient
  1. I '$G(V) Q ""
  1. NEW P S P=$P(^AUPNVSIT(V,0),U,5)
  1. Q $P($G(^DPT(P,.11)),U,6)
  1. PAP(V) ;EP - was pap performed Y/N
  1. I '$G(V) Q ""
  1. NEW T S T=$O(^ATXLAB("B","APCP PAP SMEAR LAB TESTS",0))
  1. I 'T Q ""
  1. 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"
  1. Q Y
  1. GLUCOSE(V) ;EP - return glucose test value on this visit
  1. I '$G(V) Q ""
  1. NEW T S T=$O(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0))
  1. I 'T Q ""
  1. 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)
  1. Q $E(Y,1,15) ;**********
  1. LABDONE(V,T) ;EP - return Y/N
  1. I '$G(V) Q ""
  1. I $G(T)="" Q ""
  1. S T=$O(^ATXLAB("B",T,0)) I 'T Q ""
  1. NEW %,X,Y S %="N",X=0
  1. 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"
  1. Q %
  1. LABRES(V,T) ;EP - return result of lab test in taxonomy T
  1. I '$G(V) Q ""
  1. I $G(T)="" Q ""
  1. S T=$O(^ATXLAB("B",T,0)) I 'T Q ""
  1. NEW %,X,Y S %="",X=0
  1. 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)
  1. Q $E(%,1,15) ;**********
  1. HF(V,F) ;EP was this health factor recorded on this visit
  1. I '$G(V) Q ""
  1. NEW T S T=$O(^AUTTHF("B",F,0)) I 'T Q ""
  1. 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"
  1. Q Y
  1. HFNAME(V,C) ;EP return name of health factor in this category
  1. I '$G(V) Q ""
  1. S C=$O(^AUTTHF("B",C,0)) I 'C Q ""
  1. 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)
  1. Q Y
  1. DELM(V) ;
  1. NEW S
  1. I '$G(V) Q ""
  1. S S=$S($P(^AUPNVSIT(V,0),U,7)="C":"K",1:"D")
  1. I $$CLINIC^APCLV(APCPVIEN,"C")=56 Q S
  1. I $$CLINIC^APCLV(APCPVIEN,"C")=99 Q S
  1. I $D(^AUPNVDEN("AD",APCPVIEN)) Q S
  1. Q ""
  1. UPI(V) ;EP unique Patient ID
  1. I '$G(V) Q ""
  1. NEW P S P=$P(^AUPNVSIT(V,0),U,5)
  1. I 'P Q ""
  1. 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)
  1. ;
  1. Q $P(^AUTTSITE(1,1),U,3)_$E("0000000000",1,10-$L(P))_P