APCLAPIU ; IHS/CMI/LAB - visit data ;
;;2.0;IHS PCC SUITE;**2,6,10,11,16**;MAY 14, 2009;Build 9
;
;
LASTITEM(P,APCLV,APCLT,BD,ED,APCLF) ;PEP - return last item APCLV OF TYPE APCLT DURING BD TO ED IN FORM APCLF
I $G(APCLF)="" S APCLF="D"
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
I $G(ED)="" S ED=DT
NEW APCLR,%,E,Y K APCLR S %=P_"^LAST "_APCLT_" "_APCLV_";DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"APCLR(")
I '$D(APCLR(1)) Q ""
I APCLF="D" Q $P(APCLR(1),U)
Q $$V(APCLR(1),APCLT)
;
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(^APCLCNTL("B","TERMS/FILE NUMBER",0))
I X="" Q ""
S Y=$O(^APCLCNTL(X,11,"B",T,0))
I 'Y Q ""
Q $P($G(^APCLCNTL(X,11,Y,0)),U,3)
;
F(T) ;EP
NEW X,Y
S X=$O(^APCLCNTL("B","TERMS/FILE NUMBER",0))
I X="" Q ""
S Y=$O(^APCLCNTL(X,11,"B",T,0))
I 'Y Q ""
Q $P($G(^APCLCNTL(X,11,Y,0)),U,2)
;
VF(T) ;EP
NEW X,Y
S X=$O(^APCLCNTL("B","TERMS/FILE NUMBER",0))
I X="" Q ""
S Y=$O(^APCLCNTL(X,11,"B",T,0))
I 'Y Q ""
Q $P($G(^APCLCNTL(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^ATXAPI(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^ATXAPI(C,TIEN,9)
..S R=(9999999-D)_"^DX: "_$P($$ICDDX^ICDEX(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^ATXAPI(C,TIEN,0)
..S R=(9999999-D)_"^PROC: "_$P($$ICDOP^ICDEX(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,V
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)_.9999 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^ATXAPI(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)=""
I '$D(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)_".9999" 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,LTN) ;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)
S LTN=$G(LTN)
NEW R,D,L,X,B,E,J
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
...I LTN]"",$P(^LAB(60,$P(^AUPNVLAB(X,0),U),0),U)=LTN 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
S LI=$G(LI)
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^ATXAPI(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^ATXAPI(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,SC,CL) ;PEP - GET ALL VISITS
I '$G(P) Q
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
I $G(ED)="" S ED=DT
I $G(A)="" Q
S SC=$G(SC)
S CL=$G(CL)
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
..I SC]"",$P(^AUPNVSIT(V,0),U,7)'=SC Q
..I CL,$P(^AUPNVSIT(V,0),U,8)'=CL Q
..S C=C+1
..S @A@(C)=(9999999-$P(D,"."))_"^^VISIT^^"_V
..Q
.Q
Q
ALLLAB(P,BD,ED,T,LT,LN,A) ;EP
;P - patient
;BD - beginning date
;ED - ending date
;T - lab taxonomy
;LT - loinc taxonomy
;LN - lab test name
;return all lab tests that match in array A
;FORMAT: DATE^TEST NAME^RESULT^V LAB IEN^VISIT IEN
I '$G(LT) S LT=""
S LN=$G(LN)
S T=$G(T)
NEW D,V,G,X,J,B,E,C
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" S G=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!($P(D,".")>B) D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y D
...I 'T,'LT,LN="" D SETLAB Q
...I T,$D(^ATXLAB(T,21,"B",X)) D SETLAB Q
...I LN]"",$$VAL^XBDIQ1(9000010.09,Y,.01)=LN D SETLAB Q
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...D SETLAB Q
...Q
..Q
.Q
Q
SETLAB ;
S C=C+1
S @A@(C)=(9999999-$P(D,"."))_"^"_$$VAL^XBDIQ1(9000010.09,Y,.01)_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$P(^AUPNVLAB(Y,0),U,3)
Q
IPLSNO(P,T) ;EP - any problem list entry with a SNOMED in T
NEW OUT,IN,C,G,Y,X,I,SNL,SNI
S OUT="SNL"
S X=$$SUBLST^BSTSAPI(OUT,T)
;BUILD INDEX
S C=0 F S C=$O(SNL(C)) Q:C'=+C S I=$P(SNL(C),U,1) I I]"" S SNI(I)=SNL(C)
K SNL
;LOOP PROBLEM LIST
S (X,G)=""
F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
.S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
..Q:'$D(^AUPNPROB(Y,0))
..Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
..Q:$P(^AUPNPROB(Y,0),U,12)="I" ;inactive
..I $D(SNI(X)) S G=1_U_$$CONCPT^AUPNVUTL(X)_" on their Problem List"
Q G
SNOMEDPV(P,BD,ED,T,F) ;EP - any problem list entry with a SNOMED in T
NEW OUT,IN,C,G,Y,X,I,SNL,SNI,V
I $G(T)="" Q ""
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
I $G(ED)="" S ED=DT
I $G(F)="" S F="D"
S OUT="SNL"
S X=$$SUBLST^BSTSAPI(OUT,T)
;BUILD INDEX
S C=0 F S C=$O(SNL(C)) Q:C'=+C S I=$P(SNL(C),U,1) I I]"" S SNI(I)=SNL(C)
K SNL
;LOOP V POV FOR EACH CODE
S C=0 F S C=$O(SNI(C)) Q:C="" D
.S (X,G,D)=""
.S D=$O(^AUPNVPOV("ASNC",P,C,0)) I D D
..S Y=9999999-D
..Q:Y<BD
..Q:Y>ED
..S X=$O(^AUPNVPOV("ASNC",P,C,D,0))
..Q:'X
..Q:'$D(^AUPNVPOV(X,0))
..S V=$P(^AUPNVPOV(X,0),U,3)
..S SNL(D)=(9999999-D)_U_"SNOMED: "_C_U_V_U_"9000010.07"_U_X
S D=$O(SNL(0))
I D="" Q ""
I F="D" Q $P(SNL(D),U,1)
Q SNL(D)
APCLAPIU ; IHS/CMI/LAB - visit data ;
+1 ;;2.0;IHS PCC SUITE;**2,6,10,11,16**;MAY 14, 2009;Build 9
+2 ;
+3 ;
LASTITEM(P,APCLV,APCLT,BD,ED,APCLF) ;PEP - return last item APCLV OF TYPE APCLT DURING BD TO ED IN FORM APCLF
+1 IF $GET(APCLF)=""
SET APCLF="D"
+2 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+3 IF $GET(ED)=""
SET ED=DT
+4 NEW APCLR,%,E,Y
KILL APCLR
SET %=P_"^LAST "_APCLT_" "_APCLV_";DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"APCLR(")
+5 IF '$DATA(APCLR(1))
QUIT ""
+6 IF APCLF="D"
QUIT $PIECE(APCLR(1),U)
+7 QUIT $$V(APCLR(1),APCLT)
+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(^APCLCNTL("B","TERMS/FILE NUMBER",0))
+3 IF X=""
QUIT ""
+4 SET Y=$ORDER(^APCLCNTL(X,11,"B",T,0))
+5 IF 'Y
QUIT ""
+6 QUIT $PIECE($GET(^APCLCNTL(X,11,Y,0)),U,3)
+7 ;
F(T) ;EP
+1 NEW X,Y
+2 SET X=$ORDER(^APCLCNTL("B","TERMS/FILE NUMBER",0))
+3 IF X=""
QUIT ""
+4 SET Y=$ORDER(^APCLCNTL(X,11,"B",T,0))
+5 IF 'Y
QUIT ""
+6 QUIT $PIECE($GET(^APCLCNTL(X,11,Y,0)),U,2)
+7 ;
VF(T) ;EP
+1 NEW X,Y
+2 SET X=$ORDER(^APCLCNTL("B","TERMS/FILE NUMBER",0))
+3 IF X=""
QUIT ""
+4 SET Y=$ORDER(^APCLCNTL(X,11,"B",T,0))
+5 IF 'Y
QUIT ""
+6 QUIT $PIECE($GET(^APCLCNTL(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^ATXAPI(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^ATXAPI(C,TIEN,9)
QUIT
+17 SET R=(9999999-D)_"^DX: "_$PIECE($$ICDDX^ICDEX(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^ATXAPI(C,TIEN,0)
QUIT
+17 SET R=(9999999-D)_"^PROC: "_$PIECE($$ICDOP^ICDEX(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,V
+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)_.9999
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^ATXAPI(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)_".9999"
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,LTN) ;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 SET LTN=$GET(LTN)
+11 NEW R,D,L,X,B,E,J
+12 SET R=""
SET B=9999999-BD
SET E=9999999-ED
+13 SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!($PIECE(D,".")>B)!(R]"")
QUIT
Begin DoDot:1
+14 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(R]"")
QUIT
Begin DoDot:2
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+16 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+17 IF $GET(I)
IF L=I
SET R=$$LABR(X,D)
QUIT
+18 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
+19 IF LTN]""
IF $PIECE(^LAB(60,$PIECE(^AUPNVLAB(X,0),U),0),U)=LTN
SET R=$$LABR(X,D)
QUIT
+20 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+21 IF '$$LOINC(J,$GET(LT),$GET(LO))
QUIT
+22 SET R=$$LABR(X,D)
+23 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+24 IF R=""
QUIT ""
+25 IF F="D"
QUIT $PIECE(R,U)
+26 QUIT R
+27 ;
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 SET LI=$GET(LI)
+3 IF A
IF LI
IF A=LI
QUIT 1
+4 NEW %
+5 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+6 IF %]""
IF LT
IF $DATA(^ATXAX(LT,21,"B",%))
QUIT 1
+7 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+8 IF $DATA(^ATXAX(LT,21,"B",%))
QUIT 1
+9 QUIT ""
+10 ;
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^ATXAPI(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^ATXAPI(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,SC,CL) ;PEP - GET ALL VISITS
+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 SET SC=$GET(SC)
+6 SET CL=$GET(CL)
+7 NEW B,C,D,V,E
+8 ;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
+9 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
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V
QUIT
Begin DoDot:2
+11 IF SC]""
IF $PIECE(^AUPNVSIT(V,0),U,7)'=SC
QUIT
+12 IF CL
IF $PIECE(^AUPNVSIT(V,0),U,8)'=CL
QUIT
+13 SET C=C+1
+14 SET @A@(C)=(9999999-$PIECE(D,"."))_"^^VISIT^^"_V
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT
ALLLAB(P,BD,ED,T,LT,LN,A) ;EP
+1 ;P - patient
+2 ;BD - beginning date
+3 ;ED - ending date
+4 ;T - lab taxonomy
+5 ;LT - loinc taxonomy
+6 ;LN - lab test name
+7 ;return all lab tests that match in array A
+8 ;FORMAT: DATE^TEST NAME^RESULT^V LAB IEN^VISIT IEN
+9 IF '$GET(LT)
SET LT=""
+10 SET LN=$GET(LN)
+11 SET T=$GET(T)
+12 NEW D,V,G,X,J,B,E,C
+13 ;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
+14 SET D=E-1
SET D=D_".9999"
SET G=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!($PIECE(D,".")>B)
QUIT
Begin DoDot:1
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X
QUIT
Begin DoDot:2
+16 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+17 IF 'T
IF 'LT
IF LN=""
DO SETLAB
QUIT
+18 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
DO SETLAB
QUIT
+19 IF LN]""
IF $$VAL^XBDIQ1(9000010.09,Y,.01)=LN
DO SETLAB
QUIT
+20 IF 'LT
QUIT
+21 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+22 IF '$$LOINC(J,LT)
QUIT
+23 DO SETLAB
QUIT
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 QUIT
SETLAB ;
+1 SET C=C+1
+2 SET @A@(C)=(9999999-$PIECE(D,"."))_"^"_$$VAL^XBDIQ1(9000010.09,Y,.01)_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$PIECE(^AUPNVLAB(Y,0),U,3)
+3 QUIT
IPLSNO(P,T) ;EP - any problem list entry with a SNOMED in T
+1 NEW OUT,IN,C,G,Y,X,I,SNL,SNI
+2 SET OUT="SNL"
+3 SET X=$$SUBLST^BSTSAPI(OUT,T)
+4 ;BUILD INDEX
+5 SET C=0
FOR
SET C=$ORDER(SNL(C))
IF C'=+C
QUIT
SET I=$PIECE(SNL(C),U,1)
IF I]""
SET SNI(I)=SNL(C)
+6 KILL SNL
+7 ;LOOP PROBLEM LIST
+8 SET (X,G)=""
+9 FOR
SET X=$ORDER(^AUPNPROB("APCT",P,X))
IF X=""!(G)
QUIT
Begin DoDot:1
+10 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB("APCT",P,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNPROB(Y,0))
QUIT
+12 ;deleted
IF $PIECE(^AUPNPROB(Y,0),U,12)="D"
QUIT
+13 ;inactive
IF $PIECE(^AUPNPROB(Y,0),U,12)="I"
QUIT
+14 IF $DATA(SNI(X))
SET G=1_U_$$CONCPT^AUPNVUTL(X)_" on their Problem List"
End DoDot:2
End DoDot:1
+15 QUIT G
SNOMEDPV(P,BD,ED,T,F) ;EP - any problem list entry with a SNOMED in T
+1 NEW OUT,IN,C,G,Y,X,I,SNL,SNI,V
+2 IF $GET(T)=""
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 OUT="SNL"
+7 SET X=$$SUBLST^BSTSAPI(OUT,T)
+8 ;BUILD INDEX
+9 SET C=0
FOR
SET C=$ORDER(SNL(C))
IF C'=+C
QUIT
SET I=$PIECE(SNL(C),U,1)
IF I]""
SET SNI(I)=SNL(C)
+10 KILL SNL
+11 ;LOOP V POV FOR EACH CODE
+12 SET C=0
FOR
SET C=$ORDER(SNI(C))
IF C=""
QUIT
Begin DoDot:1
+13 SET (X,G,D)=""
+14 SET D=$ORDER(^AUPNVPOV("ASNC",P,C,0))
IF D
Begin DoDot:2
+15 SET Y=9999999-D
+16 IF Y<BD
QUIT
+17 IF Y>ED
QUIT
+18 SET X=$ORDER(^AUPNVPOV("ASNC",P,C,D,0))
+19 IF 'X
QUIT
+20 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+21 SET V=$PIECE(^AUPNVPOV(X,0),U,3)
+22 SET SNL(D)=(9999999-D)_U_"SNOMED: "_C_U_V_U_"9000010.07"_U_X
End DoDot:2
End DoDot:1
+23 SET D=$ORDER(SNL(0))
+24 IF D=""
QUIT ""
+25 IF F="D"
QUIT $PIECE(SNL(D),U,1)
+26 QUIT SNL(D)
