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)
QUIT ""
+8 SET BD=9999999-BD
SET ED=9999999-ED
+9 NEW H,D,O
SET H=0
SET D=ED-1
+10 KILL O
+11 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+13 FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+14 IF D>BD
QUIT
+15 SET V=$ORDER(^AUPNVHF("AA",P,H,D,0))
+16 SET O(D)=(9999999-D)_"^HF: "_$$VAL^XBDIQ1(9000010.23,V,.01)_"^"_$$VAL^XBDIQ1(9000010.23,V,.06)_"^"_$PIECE(^AUPNVHF(V,0),U,3)_"^9000010.23^"_V
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 SET D=$ORDER(O(0))
+20 IF D=""
QUIT D
+21 IF F="D"
QUIT (9999999-D)
+22 QUIT O(D)
+23 ;
LASTBHDX(P,BD,ED,C,F) ;EP - find date of last BH dx of C, return date in fileman format
+1 NEW G,Y,V,D,E,X
+2 IF $GET(F)=""
SET F="D"
+3 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+4 IF $GET(ED)=""
SET ED=DT
+5 IF $GET(C)=""
QUIT ""
+6 SET G=""
+7 SET E=9999999-BD
SET D=9999999-ED-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(G]"")
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+8 IF '$DATA(^AMHREC(V,0))
QUIT
+9 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(G]"")
QUIT
SET Y=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+10 IF 'Y
QUIT
+11 SET Y=$PIECE($GET(^AMHPROB(Y,0)),U)
+12 IF Y=C
SET G=$PIECE($PIECE(^AMHREC(V,0),U),".")_"^BH DX: "_Y_"^"_$$VAL^XBDIQ1(9002011.01,X,.04)_"^^9002011.01^"_X
End DoDot:2
End DoDot:1
+13 IF F="D"
QUIT $PIECE(G,U)
+14 QUIT G
+15 ;
LASTBHDT(P,BD,ED,T,F) ;EP - find date of last BH dx of TAXONOMY T
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+3 IF $GET(ED)=""
SET ED=DT
+4 IF $GET(F)=""
SET F="D"
+5 SET T=$GET(T)
+6 NEW TIEN,G,Y,V,E,X,I
+7 ;get taxonomy ien
SET TIEN=""
IF T]""
SET TIEN=$ORDER(^ATXAX("B",T,0))
+8 IF TIEN=""
QUIT ""
+9 SET G=""
+10 SET E=9999999-BD
SET D=9999999-ED-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(G]"")
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+11 IF '$DATA(^AMHREC(V,0))
QUIT
+12 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(G]"")
QUIT
SET Y=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+13 IF 'Y
QUIT
+14 SET Y=$PIECE($GET(^AMHPROB(Y,0)),U)
+15 SET I=$ORDER(^ICD9("B",Y,0))
+16 IF '$$ICD^ATXCHK(I,TIEN,9)
QUIT
+17 SET G=$PIECE($PIECE(^AMHREC(V,0),U),".")_"^BH DX: "_Y_"^"_$$VAL^XBDIQ1(9002011.01,X,.04)_"^^9002011.01^"_X
End DoDot:2
End DoDot:1
+18 IF F="D"
QUIT $PIECE(G,U)
+19 QUIT G
+20 ;
LASTBHED(P,BD,ED,C,F) ;EP - find date of last BH EDUC of C, return date in fileman format
+1 NEW G,Y,V,D,E,X
+2 SET G=""
+3 SET E=9999999-BD
SET D=9999999-ED-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(G]"")
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+4 IF '$DATA(^AMHREC(V,0))
QUIT
+5 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X!(G]"")
QUIT
SET Y=$PIECE($GET(^AMHREDU(X,0)),U)
Begin DoDot:2
+6 IF 'Y
QUIT
+7 SET Y=$PIECE($GET(^AUTTEDT(Y,0)),U,2)
+8 IF Y=C
SET G=$PIECE($PIECE(^AMHREC(V,0),U),".")_"^BH: "_Y_"^"_$$VAL^XBDIQ1(9002011.05,X,.08)_"^^9002011.05^"_X
End DoDot:2
End DoDot:1
+9 IF F="D"
QUIT $PIECE(G,U)
+10 QUIT G
+11 ;
LASTDXT(P,BD,ED,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+3 IF $GET(ED)=""
SET ED=DT
+4 IF $GET(F)=""
SET F="D"
+5 SET T=$GET(T)
+6 NEW A,B,C,D,E,TIEN,R,I
+7 ;get taxonomy ien
SET TIEN=""
IF T]""
SET TIEN=$ORDER(^ATXAX("B",T,0))
+8 IF TIEN=""
QUIT ""
+9 ;return value
SET R=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET E=9999999-ED
+11 SET D=E-1
FOR
SET D=$ORDER(^AUPNVPOV("AA",P,D))
IF D=""!(D>B)!(R]"")
QUIT
Begin DoDot:1
+12 SET I=0
FOR
SET I=$ORDER(^AUPNVPOV("AA",P,D,I))
IF I'=+I!(R]"")
QUIT
Begin DoDot:2
+13 SET C=$PIECE($GET(^AUPNVPOV(I,0)),U)
+14 ;bad xref
IF C=""
QUIT
+15 IF '$DATA(^ICD9(C))
QUIT
+16 IF TIEN
IF '$$ICD^BDMUTL(C,T,9)
QUIT
+17 SET R=(9999999-D)_"^DX: "_$PIECE($$ICDDX^BDMUTL(C,(9999999-D)),U,2)_"^"_$$VAL^XBDIQ1(9000010.07,I,.04)_"^"_$PIECE(^AUPNVPOV(I,0),U,3)_"^9000010.07^"_I_"^"
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 IF R=""
QUIT ""
+21 IF F="D"
QUIT $PIECE(R,U)
+22 QUIT R
+23 ;
LASTPRCT(P,BD,ED,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+3 IF $GET(ED)=""
SET ED=DT
+4 IF $GET(F)=""
SET F="D"
+5 SET T=$GET(T)
+6 NEW A,B,C,D,E,TIEN,R,I
+7 ;get taxonomy ien
SET TIEN=""
IF T]""
SET TIEN=$ORDER(^ATXAX("B",T,0))
+8 IF TIEN=""
QUIT ""
+9 ;return value
SET R=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET E=9999999-ED
+11 SET D=E-1
FOR
SET D=$ORDER(^AUPNVPRC("AA",P,D))
IF D=""!(D>B)!(R]"")
QUIT
Begin DoDot:1
+12 SET I=0
FOR
SET I=$ORDER(^AUPNVPRC("AA",P,D,I))
IF I'=+I!(R]"")
QUIT
Begin DoDot:2
+13 SET C=$PIECE($GET(^AUPNVPRC(I,0)),U)
+14 ;bad xref
IF C=""
QUIT
+15 IF '$DATA(^ICD0(C))
QUIT
+16 IF TIEN
IF '$$ICD^ATXCHK(C,TIEN,0)
QUIT
+17 SET R=(9999999-D)_"^PROCEDURE: "_$PIECE($$ICDOP^BDMUTL(C,(9999999-D),,"I"),U,2)_"^"_$$VAL^XBDIQ1(9000010.08,I,.04)_"^"_$PIECE(^AUPNVPRC(I,0),U,3)_"^9000010.08^"_I
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 IF R=""
QUIT ""
+21 IF F="D"
QUIT $PIECE(R,U)
+22 QUIT R
+23 ;
LASTCPTT(P,BD,ED,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+3 IF $GET(ED)=""
SET ED=DT
+4 IF $GET(F)=""
SET F="D"
+5 SET T=$GET(T)
+6 NEW A,B,C,D,E,TIEN,R,I
+7 ;get taxonomy ien
SET TIEN=""
IF T]""
SET TIEN=$ORDER(^ATXAX("B",T,0))
+8 IF TIEN=""
QUIT ""
+9 ;return value
SET R=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET E=9999999-ED
+11 SET D=E-1
FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D=""!($PIECE(D,".")>B)!(R]"")
QUIT
Begin DoDot:1
+12 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V!(R]"")
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 ;no cpts
IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+15 SET I=0
FOR
SET I=$ORDER(^AUPNVCPT("AD",V,I))
IF I'=+I!(R]"")
QUIT
Begin DoDot:3
+16 SET C=$PIECE($GET(^AUPNVCPT(I,0)),U)
+17 ;bad xref
IF C=""
QUIT
+18 IF '$DATA(^ICPT(C))
QUIT
+19 IF TIEN
IF '$$ICD^ATXCHK(C,TIEN,1)
QUIT
+20 SET R=(9999999-$PIECE(D,"."))_"^CPT: "_$PIECE($$CPT^ICPTCOD(C,(9999999-$PIECE(D,"."))),U,2)_"^"_$PIECE($$CPT^ICPTCOD(C,(9999999-$PIECE(D,"."))),U,3)_"^"_$PIECE(^AUPNVCPT(I,0),U,3)_"^9000010.18^"_I
End DoDot:3
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 IF R=""
QUIT ""
+24 IF F="D"
QUIT $PIECE(R,U)
+25 QUIT R
+26 ;
LASTCPTI(P,BD,ED,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+3 IF $GET(ED)=""
SET ED=DT
+4 IF $GET(F)=""
SET F="D"
+5 SET T=$GET(T)
+6 NEW A,B,C,D,E,TIEN,R,I
+7 IF T=""
QUIT ""
+8 FOR A=1:1
SET B=$PIECE(T,";",A)
IF B=""
QUIT
SET C=$PIECE($$CPT^ICPTCOD(B),U,1)
IF C'=-1
IF C
SET TIEN(C)=""
+9 IF '$DATA(TIEN)
QUIT
+10 ;return value
SET R=""
+11 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET E=9999999-ED
+12 SET D=E-1
FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D=""!($PIECE(D,".")>B)!(R]"")
QUIT
Begin DoDot:1
+13 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V!(R]"")
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+15 ;no cpts
IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+16 SET I=0
FOR
SET I=$ORDER(^AUPNVCPT("AD",V,I))
IF I'=+I!(R]"")
QUIT
Begin DoDot:3
+17 SET C=$PIECE($GET(^AUPNVCPT(I,0)),U)
+18 ;bad xref
IF C=""
QUIT
+19 IF '$DATA(^ICPT(C))
QUIT
+20 IF '$DATA(TIEN(C))
QUIT
+21 SET R=(9999999-$PIECE(D,"."))_"^CPT: "_$PIECE($$CPT^ICPTCOD(C,(9999999-$PIECE(D,"."))),U,2)_"^"_$PIECE($$CPT^ICPTCOD(C,(9999999-$PIECE(D,"."))),U,3)_"^"_$PIECE(^AUPNVCPT(I,0),U,3)_"^9000010.18^"_I
End DoDot:3
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 IF R=""
QUIT ""
+25 IF F="D"
QUIT $PIECE(R,U)
+26 QUIT R
+27 ;
LASTBHME(P,BD,ED,C,F) ;EP - find date of last BH MEASUREMENT of C, return date in fileman format
+1 NEW G,Y,V,D,E,X
+2 SET G=""
+3 SET E=9999999-BD
SET D=9999999-ED-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(G]"")
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+4 IF '$DATA(^AMHREC(V,0))
QUIT
+5 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X!(G]"")
QUIT
SET Y=$PIECE($GET(^AMHRMSR(X,0)),U)
Begin DoDot:2
+6 IF 'Y
QUIT
+7 SET Y=$PIECE($GET(^AUTTMSR(Y,0)),U,1)
+8 IF Y=C
SET G=$PIECE($PIECE(^AMHREC(V,0),U),".")_"^BH: "_Y_"^"_$$VAL^XBDIQ1(9002011.12,X,.04)_"^^9002011.12^"_X
End DoDot:2
End DoDot:1
+9 IF F="D"
QUIT $PIECE(G,U)
+10 QUIT G
+11 ;
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
+1 ;now get all loinc/taxonomy tests
+2 IF '$GET(P)
QUIT ""
+3 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+4 IF $GET(ED)=""
SET ED=DT
+5 IF $GET(F)=""
SET F="D"
+6 SET T=$GET(T)
+7 SET I=$GET(I)
+8 SET LO=$GET(LO)
+9 SET LT=$GET(LT)
+10 NEW R,D,L,X,B,E
+11 SET R=""
SET B=9999999-BD
SET E=9999999-ED
+12 SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!($PIECE(D,".")>B)!(R]"")
QUIT
Begin DoDot:1
+13 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(R]"")
QUIT
Begin DoDot:2
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+15 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+16 IF $GET(I)
IF L=I
SET R=$$LABR(X,D)
QUIT
+17 IF $GET(T)
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(T,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET R=$$LABR(X,D)
QUIT
+18 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+19 IF '$$LOINC(J,$GET(LT),$GET(LO))
QUIT
+20 SET R=$$LABR(X,D)
+21 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 IF R=""
QUIT ""
+23 IF F="D"
QUIT $PIECE(R,U)
+24 QUIT R
+25 ;
LABR(X,D) ;
+1 QUIT (9999999-D)_"^LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_"^"_$PIECE(^AUPNVLAB(X,0),U,4)_"^"_$PIECE(^AUPNVLAB(X,0),U,3)_"^9000010.09^"_X
+2 ;
LOINC(A,LT,LI) ;
+1 ;no ien or taxonomy
IF '$GET(LT)
IF '$GET(LI)
QUIT ""
+2 IF A
IF LI
IF A=LI
QUIT 1
+3 NEW %
+4 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+5 IF %]""
IF LT
IF $DATA(^ATXAX(LT,21,"B",%))
QUIT 1
+6 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+7 IF $DATA(^ATXAX(LT,21,"B",%))
QUIT 1
+8 QUIT ""
+9 ;
LASTRADT(P,BD,ED,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+3 IF $GET(ED)=""
SET ED=DT
+4 IF $GET(F)=""
SET F="D"
+5 SET T=$GET(T)
+6 NEW A,B,C,D,E,TIEN,R,I,J,K
+7 ;get taxonomy ien
SET TIEN=""
IF T]""
SET TIEN=$ORDER(^ATXAX("B",T,0))
+8 IF TIEN=""
QUIT ""
+9 ;return value
SET R=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET E=9999999-ED
+11 SET D=E-1
FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D=""!($PIECE(D,".")>B)!(R]"")
QUIT
Begin DoDot:1
+12 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V!(R]"")
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 ;no cpts
IF '$DATA(^AUPNVRAD("AD",V))
QUIT
+15 SET I=0
FOR
SET I=$ORDER(^AUPNVRAD("AD",V,I))
IF I'=+I!(R]"")
QUIT
Begin DoDot:3
+16 SET C=$PIECE($GET(^AUPNVRAD(I,0)),U)
SET J=$PIECE($GET(^RAMIS(71,+C,0)),U,9)
+17 ;bad xref
IF C=""
QUIT
+18 ;no cpt code
IF J=""
QUIT
+19 IF '$DATA(^ICPT(J))
QUIT
+20 IF TIEN
IF '$$ICD^ATXCHK(J,TIEN,1)
QUIT
+21 SET R=(9999999-$PIECE(D,"."))_"^RADIOLOGY: "_$PIECE(^RAMIS(71,C,0),U)_" - "_$PIECE($$CPT^ICPTCOD(J,(9999999-$PIECE(D,"."))),U,2)_"^^"_$PIECE(^AUPNVRAD(I,0),U,3)_"^9000010.22^"_I
End DoDot:3
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 IF R=""
QUIT ""
+25 IF F="D"
QUIT $PIECE(R,U)
+26 QUIT R
+27 ;
LASTBHCT(P,BD,ED,T,F) ;EP - find date of last BH CPT of TAXONOMY T
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+3 IF $GET(ED)=""
SET ED=DT
+4 IF $GET(F)=""
SET F="D"
+5 SET T=$GET(T)
+6 NEW TIEN,G,Y,V,E,X,I
+7 ;get taxonomy ien
SET TIEN=""
IF T]""
SET TIEN=$ORDER(^ATXAX("B",T,0))
+8 IF TIEN=""
QUIT ""
+9 SET G=""
+10 SET E=9999999-BD
SET D=9999999-ED-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(G]"")
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+11 IF '$DATA(^AMHREC(V,0))
QUIT
+12 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X!(G]"")
QUIT
SET Y=$PIECE($GET(^AMHRPROC(X,0)),U)
Begin DoDot:2
+13 IF 'Y
QUIT
+14 IF '$$ICD^ATXCHK(Y,TIEN,1)
QUIT
+15 SET G=$PIECE($PIECE(^AMHREC(V,0),U),".")_"^BH CPT: "_$PIECE(^ICPT(Y,0),U)_"^"_$$VAL^XBDIQ1(9002011.04,X,.04)_"^^9002011.04^"_X
End DoDot:2
End DoDot:1
+16 IF F="D"
QUIT $PIECE(G,U)
+17 QUIT G
+18 ;
ALLV(P,BD,ED,A) ;EP
+1 IF '$GET(P)
QUIT
+2 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+3 IF $GET(ED)=""
SET ED=DT
+4 IF $GET(A)=""
QUIT
+5 NEW B,C,D,V,E
+6 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET C=0
SET E=9999999-ED
+7 SET D=E-1
SET D=D_".9999"
FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D=""!($PIECE(D,".")>B)
QUIT
Begin DoDot:1
+8 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V
QUIT
Begin DoDot:2
+9 SET C=C+1
+10 SET @A@(C)=(9999999-$PIECE(D,"."))_"^^VISIT^^"_V
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
AGE(P,I,D) ;EP
+1 ;---> Return Patient's Age.
+2 ;
+3 NEW B,X,X1,X2
IF $GET(I)=""
SET I=1
+4 IF '$GET(P)
QUIT ""
+5 SET BDMDOB=$$DOB^AUPNPAT(P)
+6 IF 'BDMDOB
QUIT "Unknown"
+7 IF $$DOD^AUPNPAT(P)]""
Begin DoDot:1
+8 SET X="DECEASED: "_$$DATE^BDMS9B1(+^DPT(P,.35))
End DoDot:1
QUIT X
+9 IF '$GET(D)
SET D=DT
+10 IF D<BDMDOB
QUIT "NOT BORN"
+11 ;
+12 ;---> Age in Years.
+13 NEW BDMAGEY,BDMAGEM,BDMD1,BDMD2,BDMM1,BDMM2,BDMY1,BDMY2
+14 SET BDMM1=$EXTRACT(BDMDOB,4,7)
SET BDMM2=$EXTRACT(D,4,7)
+15 SET BDMY1=$EXTRACT(BDMDOB,1,3)
SET BDMY2=$EXTRACT(D,1,3)
+16 SET BDMAGEY=BDMY2-BDMY1
IF BDMM2<BDMM1
SET BDMAGEY=BDMAGEY-1
+17 IF BDMAGEY<1
SET BDMAGEY="<1"
+18 IF I=1
QUIT BDMAGEY
+19 ;
+20 ;---> Age in Months.
+21 SET BDMD1=$EXTRACT(BDMM1,3,4)
SET BDMM1=$EXTRACT(BDMM1,1,2)
+22 SET BDMD2=$EXTRACT(BDMM2,3,4)
SET BDMM2=$EXTRACT(BDMM2,1,2)
+23 SET BDMAGEM=12*BDMAGEY
+24 IF BDMM2=BDMM1&(BDMD2<BDMD1)
SET BDMAGEM=BDMAGEM+12
+25 IF BDMM2>BDMM1
SET BDMAGEM=BDMAGEM+BDMM2-BDMM1
+26 IF BDMM2<BDMM1
SET BDMAGEM=BDMAGEM+BDMM2+(12-BDMM1)
+27 IF BDMD2<BDMD1
SET BDMAGEM=BDMAGEM-1
+28 IF I=2
QUIT BDMAGEM
+29 ;
+30 ;---> Age in Days.
+31 SET X1=D
SET X2=BDMDOB
+32 DO ^%DTC
+33 QUIT X
+34 ;
