BDMAPIU.m

BDMAPIU ; IHS/CMI/LAB - visit data ;

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2,4,6,8**;JUN 14, 2007;Build 53

 ;IHS/TUCSON/LAB - added G parameter to provider call

 ;

 ;

 ;BJPC v1.0 patch 1

 ;

LASTITEM(P,BDMV,BDMT,BD,ED,BDMF) ;PEP - return last item BDMV OF TYPE BDMT DURING BD TO ED IN FORM BDMF

 I $G(BDMF)="" S BDMF="D"

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 NEW BDMR,%,E,Y K R S %=P_"^LAST "_BDMT_" "_BDMV_";DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BDMR(")

 I '$D(BDMR(1)) Q ""

 I BDMF="D" Q $P(BDMR(1),U)

 Q $$V(BDMR(1),BDMT)

 ;

V(Y,T) ;EP

 Q $P(Y,U,1)_"^"_$$T(T)_$P(Y,U,3)_"^"_$S($$F(T)]""&($$VF(T)]""):$$VAL^XBDIQ1($$F(T),+$P(Y,U,4),$$VF(T)),1:"")_"^"_$P(Y,U,5)_"^"_$$F(T)_"^"_+$P(Y,U,4)

 ;

T(T) ;EP

 NEW X,Y

 S X=$O(^BDMCNTL("B","TERMS/FILE NUMBER",0))

 I X="" Q ""

 S Y=$O(^BDMCNTL(X,11,"B",T,0))

 I 'Y Q ""

 Q $P($G(^BDMCNTL(X,11,Y,0)),U,3)

 ;

F(T) ;EP

 NEW X,Y

 S X=$O(^BDMCNTL("B","TERMS/FILE NUMBER",0))

 I X="" Q ""

 S Y=$O(^BDMCNTL(X,11,"B",T,0))

 I 'Y Q ""

 Q $P($G(^BDMCNTL(X,11,Y,0)),U,2)

 ;

VF(T) ;EP

 NEW X,Y

 S X=$O(^BDMCNTL("B","TERMS/FILE NUMBER",0))

 I X="" Q ""

 S Y=$O(^BDMCNTL(X,11,"B",T,0))

 I 'Y Q ""

 Q $P($G(^BDMCNTL(X,11,Y,0)),U,4)

 ;

LASTHF(P,C,BD,ED,F) ;PEP - get last factor in category C for patient P between BD and ED

 I '$G(P) Q ""

 I $G(C)="" Q ""

 I $G(F)="" S F=""

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED) S ED=DT

 S C=$O(^AUTTHF("B",C,0)) ;ien of category passed

 I '$G(C) Q ""

 S BD=9999999-BD,ED=9999999-ED

 NEW H,D,O S H=0,D=ED-1

 K O

 F  S H=$O(^AUTTHF("AC",C,H))  Q:'+H  D

 .  Q:'$D(^AUPNVHF("AA",P,H))

 .  F  S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D  D

 .. Q:D>BD

 .. S V=$O(^AUPNVHF("AA",P,H,D,0))

 .. S O(D)=(9999999-D)_"^HF: "_$$VAL^XBDIQ1(9000010.23,V,.01)_"^"_$$VAL^XBDIQ1(9000010.23,V,.06)_"^"_$P(^AUPNVHF(V,0),U,3)_"^9000010.23^"_V

 .. Q

 .  Q

 S D=$O(O(0))

 I D="" Q D

 I F="D" Q (9999999-D)

 Q O(D)

 ;

LASTBHDX(P,BD,ED,C,F) ;EP - find date of last BH dx of C, return date in fileman format

 NEW G,Y,V,D,E,X

 I $G(F)="" S F="D"

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(C)="" Q ""

 S G=""

 S E=9999999-BD,D=9999999-ED-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(G]"")  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(G]"")  D

 .Q:'$D(^AMHREC(V,0))

 .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(G]"")  S Y=$P($G(^AMHRPRO(X,0)),U) D

 ..Q:'Y

 ..S Y=$P($G(^AMHPROB(Y,0)),U)

 ..I Y=C S G=$P($P(^AMHREC(V,0),U),".")_"^BH DX: "_Y_"^"_$$VAL^XBDIQ1(9002011.01,X,.04)_"^^9002011.01^"_X

 I F="D" Q $P(G,U)

 Q G

 ;

LASTBHDT(P,BD,ED,T,F) ;EP - find date of last BH dx of TAXONOMY T

 I $G(P)="" Q ""

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(F)="" S F="D"

 S T=$G(T)

 NEW TIEN,G,Y,V,E,X,I

 S TIEN="" I T]"" S TIEN=$O(^ATXAX("B",T,0))  ;get taxonomy ien

 I TIEN="" Q ""

 S G=""

 S E=9999999-BD,D=9999999-ED-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(G]"")  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(G]"")  D

 .Q:'$D(^AMHREC(V,0))

 .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(G]"")  S Y=$P($G(^AMHRPRO(X,0)),U) D

 ..Q:'Y

 ..S Y=$P($G(^AMHPROB(Y,0)),U)

 ..S I=$O(^ICD9("B",Y,0))

 ..Q:'$$ICD^ATXCHK(I,TIEN,9)

 ..S G=$P($P(^AMHREC(V,0),U),".")_"^BH DX: "_Y_"^"_$$VAL^XBDIQ1(9002011.01,X,.04)_"^^9002011.01^"_X

 I F="D" Q $P(G,U)

 Q G

 ;

LASTBHED(P,BD,ED,C,F) ;EP - find date of last BH EDUC of C, return date in fileman format

 NEW G,Y,V,D,E,X

 S G=""

 S E=9999999-BD,D=9999999-ED-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(G]"")  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(G]"")  D

 .Q:'$D(^AMHREC(V,0))

 .S X=0 F  S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(G]"")  S Y=$P($G(^AMHREDU(X,0)),U) D

 ..Q:'Y

 ..S Y=$P($G(^AUTTEDT(Y,0)),U,2)

 ..I Y=C S G=$P($P(^AMHREC(V,0),U),".")_"^BH: "_Y_"^"_$$VAL^XBDIQ1(9002011.05,X,.08)_"^^9002011.05^"_X

 I F="D" Q $P(G,U)

 Q G

 ;

LASTDXT(P,BD,ED,T,F) ;EP

 I '$G(P) Q ""

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(F)="" S F="D"

 S T=$G(T)

 NEW A,B,C,D,E,TIEN,R,I

 S TIEN="" I T]"" S TIEN=$O(^ATXAX("B",T,0))  ;get taxonomy ien

 I TIEN="" Q ""

 S R=""  ;return value

 S B=9999999-BD,E=9999999-ED  ;get inverse date and begin at edate-1 and end when greater than begin date

 S D=E-1 F  S D=$O(^AUPNVPOV("AA",P,D)) Q:D=""!(D>B)!(R]"")  D

 .S I=0 F  S I=$O(^AUPNVPOV("AA",P,D,I)) Q:I'=+I!(R]"")  D

 ..S C=$P($G(^AUPNVPOV(I,0)),U)

 ..Q:C=""  ;bad xref

 ..Q:'$D(^ICD9(C))

 ..I TIEN Q:'$$ICD^BDMUTL(C,T,9)

 ..S R=(9999999-D)_"^DX: "_$P($$ICDDX^BDMUTL(C,(9999999-D)),U,2)_"^"_$$VAL^XBDIQ1(9000010.07,I,.04)_"^"_$P(^AUPNVPOV(I,0),U,3)_"^9000010.07^"_I_"^"

 ..Q

 .Q

 I R="" Q ""

 I F="D" Q $P(R,U)

 Q R

 ;

LASTPRCT(P,BD,ED,T,F) ;EP

 I '$G(P) Q ""

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(F)="" S F="D"

 S T=$G(T)

 NEW A,B,C,D,E,TIEN,R,I

 S TIEN="" I T]"" S TIEN=$O(^ATXAX("B",T,0))  ;get taxonomy ien

 I TIEN="" Q ""

 S R=""  ;return value

 S B=9999999-BD,E=9999999-ED  ;get inverse date and begin at edate-1 and end when greater than begin date

 S D=E-1 F  S D=$O(^AUPNVPRC("AA",P,D)) Q:D=""!(D>B)!(R]"")  D

 .S I=0 F  S I=$O(^AUPNVPRC("AA",P,D,I)) Q:I'=+I!(R]"")  D

 ..S C=$P($G(^AUPNVPRC(I,0)),U)

 ..Q:C=""  ;bad xref

 ..Q:'$D(^ICD0(C))

 ..I TIEN Q:'$$ICD^ATXCHK(C,TIEN,0)

 ..S R=(9999999-D)_"^PROCEDURE: "_$P($$ICDOP^BDMUTL(C,(9999999-D),,"I"),U,2)_"^"_$$VAL^XBDIQ1(9000010.08,I,.04)_"^"_$P(^AUPNVPRC(I,0),U,3)_"^9000010.08^"_I

 ..Q

 .Q

 I R="" Q ""

 I F="D" Q $P(R,U)

 Q R

 ;

LASTCPTT(P,BD,ED,T,F) ;EP

 I '$G(P) Q ""

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(F)="" S F="D"

 S T=$G(T)

 NEW A,B,C,D,E,TIEN,R,I

 S TIEN="" I T]"" S TIEN=$O(^ATXAX("B",T,0))  ;get taxonomy ien

 I TIEN="" Q ""

 S R=""  ;return value

 S B=9999999-BD,E=9999999-ED  ;get inverse date and begin at edate-1 and end when greater than begin date

 S D=E-1 F  S D=$O(^AUPNVSIT("AA",P,D)) Q:D=""!($P(D,".")>B)!(R]"")  D

 .S V=0 F  S V=$O(^AUPNVSIT("AA",P,D,V)) Q:V'=+V!(R]"")  D

 ..Q:'$D(^AUPNVSIT(V,0))

 ..Q:'$D(^AUPNVCPT("AD",V))  ;no cpts

 ..S I=0 F  S I=$O(^AUPNVCPT("AD",V,I)) Q:I'=+I!(R]"")  D

 ...S C=$P($G(^AUPNVCPT(I,0)),U)

 ...Q:C=""  ;bad xref

 ...Q:'$D(^ICPT(C))

 ...I TIEN Q:'$$ICD^ATXCHK(C,TIEN,1)

 ...S R=(9999999-$P(D,"."))_"^CPT: "_$P($$CPT^ICPTCOD(C,(9999999-$P(D,"."))),U,2)_"^"_$P($$CPT^ICPTCOD(C,(9999999-$P(D,"."))),U,3)_"^"_$P(^AUPNVCPT(I,0),U,3)_"^9000010.18^"_I

 ..Q

 .Q

 I R="" Q ""

 I F="D" Q $P(R,U)

 Q R

 ;

LASTCPTI(P,BD,ED,T,F) ;EP

 I '$G(P) Q ""

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(F)="" S F="D"

 S T=$G(T)

 NEW A,B,C,D,E,TIEN,R,I

 I T="" Q ""

 F A=1:1 S B=$P(T,";",A) Q:B=""  S C=$P($$CPT^ICPTCOD(B),U,1) I C'=-1,C S TIEN(C)=""

 Q:'$D(TIEN)

 S R=""  ;return value

 S B=9999999-BD,E=9999999-ED  ;get inverse date and begin at edate-1 and end when greater than begin date

 S D=E-1 F  S D=$O(^AUPNVSIT("AA",P,D)) Q:D=""!($P(D,".")>B)!(R]"")  D

 .S V=0 F  S V=$O(^AUPNVSIT("AA",P,D,V)) Q:V'=+V!(R]"")  D

 ..Q:'$D(^AUPNVSIT(V,0))

 ..Q:'$D(^AUPNVCPT("AD",V))  ;no cpts

 ..S I=0 F  S I=$O(^AUPNVCPT("AD",V,I)) Q:I'=+I!(R]"")  D

 ...S C=$P($G(^AUPNVCPT(I,0)),U)

 ...Q:C=""  ;bad xref

 ...Q:'$D(^ICPT(C))

 ...Q:'$D(TIEN(C))

 ...S R=(9999999-$P(D,"."))_"^CPT: "_$P($$CPT^ICPTCOD(C,(9999999-$P(D,"."))),U,2)_"^"_$P($$CPT^ICPTCOD(C,(9999999-$P(D,"."))),U,3)_"^"_$P(^AUPNVCPT(I,0),U,3)_"^9000010.18^"_I

 ..Q

 .Q

 I R="" Q ""

 I F="D" Q $P(R,U)

 Q R

 ;

LASTBHME(P,BD,ED,C,F) ;EP - find date of last BH MEASUREMENT of C, return date in fileman format

 NEW G,Y,V,D,E,X

 S G=""

 S E=9999999-BD,D=9999999-ED-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(G]"")  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(G]"")  D

 .Q:'$D(^AMHREC(V,0))

 .S X=0 F  S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(G]"")  S Y=$P($G(^AMHRMSR(X,0)),U) D

 ..Q:'Y

 ..S Y=$P($G(^AUTTMSR(Y,0)),U,1)

 ..I Y=C S G=$P($P(^AMHREC(V,0),U),".")_"^BH: "_Y_"^"_$$VAL^XBDIQ1(9002011.12,X,.04)_"^^9002011.12^"_X

 I F="D" Q $P(G,U)

 Q G

 ;

LASTLAB(P,BD,ED,I,T,LO,LT,F) ;EP P is patient, I is ien of lab test, T is IEN of lab taxonomy, LO is ien of loinc code,  LT is ien o f loinc taxonmy

 ;now get all loinc/taxonomy tests

 I '$G(P) Q ""

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(F)="" S F="D"

 S T=$G(T)

 S I=$G(I)

 S LO=$G(LO)

 S LT=$G(LT)

 NEW R,D,L,X,B,E

 S R="",B=9999999-BD,E=9999999-ED

 S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!($P(D,".")>B)!(R]"")  D

 .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(R]"")  D

 ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(R]"")  D

 ...Q:'$D(^AUPNVLAB(X,0))

 ...I $G(I),L=I S R=$$LABR(X,D) Q

 ...I $G(T),$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(T,21,"B",$P(^AUPNVLAB(X,0),U))) S R=$$LABR(X,D) Q

 ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""

 ...Q:'$$LOINC(J,$G(LT),$G(LO))

 ...S R=$$LABR(X,D)

 ...Q

 I R="" Q ""

 I F="D" Q $P(R,U)

 Q R

 ;

LABR(X,D) ;

 Q (9999999-D)_"^LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_"^"_$P(^AUPNVLAB(X,0),U,4)_"^"_$P(^AUPNVLAB(X,0),U,3)_"^9000010.09^"_X

 ;

LOINC(A,LT,LI) ;

 I '$G(LT),'$G(LI) Q ""  ;no ien or taxonomy

 I A,LI,A=LI Q 1

 NEW %

 S %=$P($G(^LAB(95.3,A,9999999)),U,2)

 I %]"",LT,$D(^ATXAX(LT,21,"B",%)) Q 1

 S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)

 I $D(^ATXAX(LT,21,"B",%)) Q 1

 Q ""

 ;

LASTRADT(P,BD,ED,T,F) ;EP

 I '$G(P) Q ""

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(F)="" S F="D"

 S T=$G(T)

 NEW A,B,C,D,E,TIEN,R,I,J,K

 S TIEN="" I T]"" S TIEN=$O(^ATXAX("B",T,0))  ;get taxonomy ien

 I TIEN="" Q ""

 S R=""  ;return value

 S B=9999999-BD,E=9999999-ED  ;get inverse date and begin at edate-1 and end when greater than begin date

 S D=E-1 F  S D=$O(^AUPNVSIT("AA",P,D)) Q:D=""!($P(D,".")>B)!(R]"")  D

 .S V=0 F  S V=$O(^AUPNVSIT("AA",P,D,V)) Q:V'=+V!(R]"")  D

 ..Q:'$D(^AUPNVSIT(V,0))

 ..Q:'$D(^AUPNVRAD("AD",V))  ;no cpts

 ..S I=0 F  S I=$O(^AUPNVRAD("AD",V,I)) Q:I'=+I!(R]"")  D

 ...S C=$P($G(^AUPNVRAD(I,0)),U),J=$P($G(^RAMIS(71,+C,0)),U,9)

 ...Q:C=""  ;bad xref

 ...Q:J=""  ;no cpt code

 ...Q:'$D(^ICPT(J))

 ...I TIEN Q:'$$ICD^ATXCHK(J,TIEN,1)

 ...S R=(9999999-$P(D,"."))_"^RADIOLOGY: "_$P(^RAMIS(71,C,0),U)_" - "_$P($$CPT^ICPTCOD(J,(9999999-$P(D,"."))),U,2)_"^^"_$P(^AUPNVRAD(I,0),U,3)_"^9000010.22^"_I

 ..Q

 .Q

 I R="" Q ""

 I F="D" Q $P(R,U)

 Q R

 ;

LASTBHCT(P,BD,ED,T,F) ;EP - find date of last BH CPT of TAXONOMY T

 I $G(P)="" Q ""

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(F)="" S F="D"

 S T=$G(T)

 NEW TIEN,G,Y,V,E,X,I

 S TIEN="" I T]"" S TIEN=$O(^ATXAX("B",T,0))  ;get taxonomy ien

 I TIEN="" Q ""

 S G=""

 S E=9999999-BD,D=9999999-ED-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(G]"")  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(G]"")  D

 .Q:'$D(^AMHREC(V,0))

 .S X=0 F  S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(G]"")  S Y=$P($G(^AMHRPROC(X,0)),U) D

 ..Q:'Y

 ..Q:'$$ICD^ATXCHK(Y,TIEN,1)

 ..S G=$P($P(^AMHREC(V,0),U),".")_"^BH CPT: "_$P(^ICPT(Y,0),U)_"^"_$$VAL^XBDIQ1(9002011.04,X,.04)_"^^9002011.04^"_X

 I F="D" Q $P(G,U)

 Q G

 ;

ALLV(P,BD,ED,A) ;EP

 I '$G(P) Q

 I $G(BD)="" S BD=$$DOB^AUPNPAT(P)

 I $G(ED)="" S ED=DT

 I $G(A)="" Q

 NEW B,C,D,V,E

 S B=9999999-BD,C=0,E=9999999-ED  ;get inverse date and begin at edate-1 and end when greater than begin date

 S D=E-1,D=D_".9999" F  S D=$O(^AUPNVSIT("AA",P,D)) Q:D=""!($P(D,".")>B)  D

 .S V=0 F  S V=$O(^AUPNVSIT("AA",P,D,V)) Q:V'=+V  D

 ..S C=C+1

 ..S @A@(C)=(9999999-$P(D,"."))_"^^VISIT^^"_V

 ..Q

 .Q

 Q

AGE(P,I,D) ;EP

 ;---> Return Patient's Age.

 ;

 N B,X,X1,X2  S:$G(I)="" I=1

 Q:'$G(P) ""

 S BDMDOB=$$DOB^AUPNPAT(P)

 Q:'BDMDOB "Unknown"

 I $$DOD^AUPNPAT(P)]"" D  Q X

 .S X="DECEASED: "_$$DATE^BDMS9B1(+^DPT(P,.35))

 S:'$G(D) D=DT

 Q:D<BDMDOB "NOT BORN"

 ;

 ;---> Age in Years.

 N BDMAGEY,BDMAGEM,BDMD1,BDMD2,BDMM1,BDMM2,BDMY1,BDMY2

 S BDMM1=$E(BDMDOB,4,7),BDMM2=$E(D,4,7)

 S BDMY1=$E(BDMDOB,1,3),BDMY2=$E(D,1,3)

 S BDMAGEY=BDMY2-BDMY1 S:BDMM2<BDMM1 BDMAGEY=BDMAGEY-1

 S:BDMAGEY<1 BDMAGEY="<1"

 Q:I=1 BDMAGEY

 ;

 ;---> Age in Months.

 S BDMD1=$E(BDMM1,3,4),BDMM1=$E(BDMM1,1,2)

 S BDMD2=$E(BDMM2,3,4),BDMM2=$E(BDMM2,1,2)

 S BDMAGEM=12*BDMAGEY

 I BDMM2=BDMM1&(BDMD2<BDMD1) S BDMAGEM=BDMAGEM+12

 I BDMM2>BDMM1 S BDMAGEM=BDMAGEM+BDMM2-BDMM1

 I BDMM2<BDMM1 S BDMAGEM=BDMAGEM+BDMM2+(12-BDMM1)

 S:BDMD2<BDMD1 BDMAGEM=BDMAGEM-1

 Q:I=2 BDMAGEM

 ;

 ;---> Age in Days.

 S X1=D,X2=BDMDOB

 D ^%DTC

 Q X

 ;

BDMAPIU   ; IHS/CMI/LAB - visit data ;

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**2,4,6,8**;JUN 14, 2007;Build 53

 +2       ;IHS/TUCSON/LAB - added G parameter to provider call

 +3       ;

 +4       ;

 +5       ;BJPC v1.0 patch 1

 +6       ;

LASTITEM(P,BDMV,BDMT,BD,ED,BDMF) ;PEP - return last item BDMV OF TYPE BDMT DURING BD TO ED IN FORM BDMF

 +1        IF $GET(BDMF)=""

               SET BDMF="D"

 +2        IF $GET(BD)=""

               SET BD=$$DOB^AUPNPAT(P)

 +3        IF $GET(ED)=""

               SET ED=DT

 +4        NEW BDMR,%,E,Y

           KILL R

           SET %=P_"^LAST "_BDMT_" "_BDMV_";DURING "_BD_"-"_ED

           SET E=$$START1^APCLDF(%,"BDMR(")

 +5        IF '$DATA(BDMR(1))

               QUIT ""

 +6        IF BDMF="D"

               QUIT $PIECE(BDMR(1),U)

 +7        QUIT $$V(BDMR(1),BDMT)

 +8       ;

V(Y,T)    ;EP

 +1        QUIT $PIECE(Y,U,1)_"^"_$$T(T)_$PIECE(Y,U,3)_"^"_$SELECT($$F(T)]""&($$VF(T)]""):$$VAL^XBDIQ1($$F(T),+$PIECE(Y,U,4),$$VF(T)),1:"")_"^"_$PIECE(Y,U,5)_"^"_$$F(T)_"^"_+$PIECE(Y,U,4)

 +2       ;

T(T)      ;EP

 +1        NEW X,Y

 +2        SET X=$ORDER(^BDMCNTL("B","TERMS/FILE NUMBER",0))

 +3        IF X=""

               QUIT ""

 +4        SET Y=$ORDER(^BDMCNTL(X,11,"B",T,0))

 +5        IF 'Y

               QUIT ""

 +6        QUIT $PIECE($GET(^BDMCNTL(X,11,Y,0)),U,3)

 +7       ;

F(T)      ;EP

 +1        NEW X,Y

 +2        SET X=$ORDER(^BDMCNTL("B","TERMS/FILE NUMBER",0))

 +3        IF X=""

               QUIT ""

 +4        SET Y=$ORDER(^BDMCNTL(X,11,"B",T,0))

 +5        IF 'Y

               QUIT ""

 +6        QUIT $PIECE($GET(^BDMCNTL(X,11,Y,0)),U,2)

 +7       ;

VF(T)     ;EP

 +1        NEW X,Y

 +2        SET X=$ORDER(^BDMCNTL("B","TERMS/FILE NUMBER",0))

 +3        IF X=""

               QUIT ""

 +4        SET Y=$ORDER(^BDMCNTL(X,11,"B",T,0))

 +5        IF 'Y

               QUIT ""

 +6        QUIT $PIECE($GET(^BDMCNTL(X,11,Y,0)),U,4)

 +7       ;

LASTHF(P,C,BD,ED,F) ;PEP - get last factor in category C for patient P between BD and ED

 +1        IF '$GET(P)

               QUIT ""

 +2        IF $GET(C)=""

               QUIT ""

 +3        IF $GET(F)=""

               SET F=""

 +4        IF $GET(BD)=""

               SET BD=$$DOB^AUPNPAT(P)

 +5        IF $GET(ED)

               SET ED=DT

 +6       ;ien of category passed

           SET C=$ORDER(^AUTTHF("B",C,0))

 +7        IF '$GET(C)