BUDCRPC1 ; IHS/CMI/LAB - UDS TABLE 6 ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
PT ;
I $G(BUDT6L) S ^XTMP("BUDCRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$G(^XTMP("BUDCRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV))_$E(BUDVAL,1,20)_U
PT1 S $P(BUDT6("V"),U,BUDORD)=$P(BUDT6("V"),U,BUDORD)+1
I $D(^TMP($J,"PATIENTS",DFN,BUDORD)) Q
S ^TMP($J,"PATIENTS",DFN,BUDORD)=""
S $P(BUDT6("P"),U,BUDORD)=$P(BUDT6("P"),U,BUDORD)+1
Q
OT ;
I $D(^XTMP("BUDCRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN)) Q ;patient already a hit on this line
S ^XTMP("BUDCRPT1",BUDJ,BUDH,"ORPHANS",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$E(BUDVAL,1,20)
Q
T6 ;EP
S BUDV=0 F S BUDV=$O(^TMP($J,"VISITS356A",BUDV)) Q:BUDV'=+BUDV D
.S BUDP=$$PRIMPROV^APCLV(BUDV,"D") Q:BUDP=""
.S BUDIEN=0 F S BUDIEN=$O(^AUPNVPOV("AD",BUDV,BUDIEN)) Q:BUDIEN'=+BUDIEN D
..S BUDPOV=$$VAL^XBDIQ1(9000010.07,BUDIEN,.01),BUDPOVP=$P(^AUPNVPOV(BUDIEN,0),U,1) ;$$PRIMPOV^APCLV(BUDV,"C") Q:BUDPOV="" S BUDPOVP=$$PRIMPOV^APCLV(BUDV,"I")
..D PRIMDX
SERV1 ;NOW DO SERVICES ON FULL LIST
S BUDV=0 F S BUDV=$O(^TMP($J,"VISITSLIST",BUDV)) Q:BUDV'=+BUDV D SERV
Q
PRIMDX ;
S BUDLINE=$O(^BUDCTSC("AC",BUDPOVP,0))
I BUDLINE="" Q ;Q ;LORI FIX THIS LATER
S BUDORD=$P(^BUDCTSC(BUDLINE,0),U,1) ;order
S BUDVAL=BUDPOV
D PT
Q
SERV ;
S BUDORD=30 F S BUDORD=$O(^BUDCTSC("B",BUDORD)) Q:BUDORD'=+BUDORD S BUDY=0 F S BUDY=$O(^BUDCTSC("B",BUDORD,BUDY)) Q:BUDY'=+BUDY D
.S BUDVAL=""
.Q:$P(^BUDCTSC(BUDY,0),U,2) ;header only
.X ^BUDCTSC(BUDY,1)
.Q:BUDVAL=""
.D PT
Q
MAM ;EP
S BUDVAL=$$MAMM(BUDV) I BUDVAL]"" Q
I BUDVAL="" D
.S BUDW=0 F S BUDW=$O(^TMP($J,"MAMMS",BUDW)) Q:BUDW'=+BUDW D
..S D=$S($$VERSION^XPDUTL("BW")<3:$P($G(^BWPCD(BUDW,0)),U,12),1:$P(^TMP($J,"MAMMS",BUDW),U,3))
..Q:D'=$P($P($G(^AUPNVSIT(BUDV,0)),U),".") ;pap not on this visit date
..Q:$D(^TMP($J,"MAMDATE",$P($P(^AUPNVSIT(BUDV,0),U),"."))) ;ALREADY HAVE A PAP ON THIS DATE
..D PT1 S ^XTMP("BUDCRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW)=^TMP($J,"MAMMS",BUDW)
..S ^TMP($J,"MAMDATE",$P($P($G(^AUPNVSIT(BUDV,0)),U),"."))=""
Q
PAP1 ;
S BUDVAL=$$PAP(BUDV) I BUDVAL]"" Q
I BUDVAL="" D
.S BUDW=0 F S BUDW=$O(^TMP($J,"PAPS",BUDW)) Q:BUDW'=+BUDW D
..S D=$S($$VERSION^XPDUTL("BW")<3:$P($G(^BWPCD(BUDW,0)),U,12),1:$P(^TMP($J,"PAPS",BUDW),U,3))
..Q:D'=$P($P($G(^AUPNVSIT(BUDV,0)),U),".")
..Q:$D(^TMP($J,"PAPDATE",$P($P(^AUPNVSIT(BUDV,0),U),"."))) ;ALREADY HAVE A PAP ON THIS DATE
..D PT1 S ^XTMP("BUDCRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW)=^TMP($J,"PAPS",BUDW)
..S ^TMP($J,"PAPDATE",$P($P($G(^AUPNVSIT(BUDV,0)),U),"."))=""
Q
CONTRA(BUDV) ;
S G="",X=0 F S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X!(G]"") S R=$P(^AUPNVPOV(X,0),U),R=$P($$ICDDX^ICDEX(R,$$VD^APCLV(BUDV)),U,2) I $E(R,1,3)="V25"!($E(R,1,3)="Z30") S G=R
Q G
SEASFLU(BUDV) ;
S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$P(^AUPNVCPT(X,0),U)
.S Z=$P($$CPT^ICPTCOD(Z),U,2)
.I Z>90653,Z<90663 S G=Z Q
.I Z>90671,Z<90674 S G=Z Q
.I Z>90684,Z<90689 S G=Z Q
.Q
I G]"" Q "V CPT: "_G
S G="",X=0 F S X=$O(^AUPNVIMM("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$P(^AUPNVIMM(X,0),U),Z=+$P(^AUTTIMM(Z,0),U,3)
.I Z=15!(Z=16)!(Z=111)!(Z=88)!(Z=135)!(Z=140)!(Z=141)!(Z=144)!(Z=149)!(Z=150)!(Z=151)!(Z=153)!(Z=155)!(Z=158)!(Z=161)!(Z=166) S G=Z_" imm"
.Q
Q G
;
;
PAP(BUDV) ;
S T=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
S G="" I T S X=0 F S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"") S R=$P($G(^AUPNVLAB(X,0)),U) I R,$D(^ATXLAB(T,21,"B",R)) S G=$P(^LAB(60,R,0),U)
I G]"" Q "V LAB: "_G
S X=0 F S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"") S R=$P(^AUPNVLAB(X,0),U),R=$P(^LAB(60,R,0),U) I R="PAP SMEAR" S G=R
I G]"" Q "V LAB: "_G
S T=$O(^ATXAX("B","BUD CPT PAP 10",0))
S G="" I T S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$P(^AUPNVCPT(X,0),U)
.I $$ICD^ATXCHK(Z,T,1) S G=$P($$CPT^ICPTCOD(Z),U,2)
.Q
I G]"" Q "V CPT: "_G
S X=0,G="" F S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$P(^AUPNVPOV(X,0),U),Z=$P($$ICDDX^ICDEX(Z,$$VD^APCLV(BUDV)),U,2)
.I Z="V76.2"!(Z="V72.3")!(Z="V72.31")!(Z="V72.32")!($E(Z,1,6)="Z01.41")!($E(Z,1,6)="Z01.42")!($E(Z,1,5)="Z12.4") S G=Z ;!(Z="V72.32")!(Z="V76.47")!(Z="V67.01")!($E(Z,1,5)="795.0") S G=Z
I G]"" Q "V POV: "_G
S X=0,G="" F S X=$O(^AUPNVPRC("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$$GET1^DIQ(9000010.08,X,.01)
.I Z="91.46" S G=Z
I G]"" Q "V PROCEDURE: "_G
S T=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
S G="" I T S X=0 F S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S J=$P($G(^AUPNVLAB(X,11)),U,13)
.Q:J=""
.Q:'$$LOINC(J,T)
.S G=J
I G]"" Q "V LAB LOINC: "_G
Q ""
IMM(BUDV) ;
S T=$O(^ATXAX("B","BUD 12 CPT IMM LINE 24",0))
S G="" I T S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$P(^AUPNVCPT(X,0),U)
.I $$ICD^ATXCHK(Z,T,1) S G=$P($$CPT^ICPTCOD(Z),U,2)
.Q
I G]"" Q "V CPT: "_G
S G="",X=0 F S X=$O(^AUPNVIMM("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$P(^AUPNVIMM(X,0),U),Z=+$P(^AUTTIMM(Z,0),U,3)
.S BUDTIEN=$O(^BUDCCNTL("B","IMMUNIZATIONS LINE 24",0))
.I $D(^BUDCCNTL(BUDTIEN,11,"B",Z)) S G=Z_" imm"
.Q
Q G
HIV(BUDV) ;EP
S T=$O(^ATXLAB("B","BGP HIV TEST TAX",0))
S G="" I T S X=0 F S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"") S R=$P($G(^AUPNVLAB(X,0)),U) I R,$D(^ATXLAB(T,21,"B",R)) S G=$P(^LAB(60,R,0),U)
I G]"" Q "V LAB: "_G
;S T=$O(^ATXAX("B","BUD CPT HIV TESTS",0))
S G="" I T S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$P(^AUPNVCPT(X,0),U)
.S %=$$VAL^XBDIQ1(9000010.18,X,.01)
.I %=86689!(%=86701)!(%=86702)!(%=86703)!(%=87390)!(%=87391) S G=$P($$CPT^ICPTCOD(Z),U,2)
.Q
I G]"" Q "V CPT: "_G
S T=$O(^ATXAX("B","BGP HIV TEST LOINC CODES",0))
S G="" I T S X=0 F S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S J=$P($G(^AUPNVLAB(X,11)),U,13)
.Q:J=""
.Q:'$$LOINC(J,T)
.S G=J
I G]"" Q "V LAB LOINC: "_G
Q ""
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,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(B,21,"B",%)) Q 1
Q ""
MAMM(BUDV) ;
S X=0,G="" F S X=$O(^AUPNVRAD("AD",BUDV,X)) Q:X'=+X D
.S Z=$P(^AUPNVRAD(X,0),U),Z=$P(^RAMIS(71,Z,0),U,9) I Z S Y=$P($$CPT^ICPTCOD(Z),U,2)
.I Y=77057!(Y=77052) S G=Y
I G]"" Q "V RAD: "_G
S X=0,G="" F S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X D
.S Z=$P(^AUPNVPOV(X,0),U),Z=$P($$ICDDX^ICDEX(Z,$$VD^APCLV(BUDV)),U,2)
.I Z="V76.11"!(Z="V76.12")!($E(Z,1,6)="Z12.31") S G=Z
I G]"" Q "V POV: "_G
S X=0,G="" F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X D
.S Z=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Z),U,2)
.I Y=77057!(Y=77052) S G="V CPT: "_Y
I G]"" Q "V CPT: "_Y
Q ""
HEPB(BUDV) ;
S T=$O(^ATXLAB("B","BUD HEPATITIS B TESTS",0))
S G="" I T S X=0 F S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"") S R=$P($G(^AUPNVLAB(X,0)),U) I R,$D(^ATXLAB(T,21,"B",R)) S G=$P(^LAB(60,R,0),U)
I G]"" Q "V LAB: "_G
S T=$O(^ATXAX("B","BUD CPT HEPATITIS B TESTS",0))
S G="" I T S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$P(^AUPNVCPT(X,0),U)
.I $$ICD^ATXCHK(Z,T,1) S G=$P($$CPT^ICPTCOD(Z),U,2)
.Q
I G]"" Q "V CPT: "_G
Q ""
HEPC(BUDV) ;
S T=$O(^ATXLAB("B","BUD HEPATITIS C TESTS",0))
S G="" I T S X=0 F S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"") S R=$P($G(^AUPNVLAB(X,0)),U) I R,$D(^ATXLAB(T,21,"B",R)) S G=$P(^LAB(60,R,0),U)
I G]"" Q "V LAB: "_G
S T=$O(^ATXAX("B","BUD CPT HEPATITIS C TESTS",0))
S G="" I T S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$P(^AUPNVCPT(X,0),U)
.I $$ICD^ATXCHK(Z,T,1) S G=$P($$CPT^ICPTCOD(Z),U,2)
.Q
I G]"" Q "V CPT: "_G
Q ""
BUDCRPC1 ; IHS/CMI/LAB - UDS TABLE 6 ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
PT ;
+1 IF $GET(BUDT6L)
SET ^XTMP("BUDCRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$GET(^XTMP("BUDCRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV))_$EXTRACT(BUDVAL,1,20)_U
PT1 SET $PIECE(BUDT6("V"),U,BUDORD)=$PIECE(BUDT6("V"),U,BUDORD)+1
+1 IF $DATA(^TMP($JOB,"PATIENTS",DFN,BUDORD))
QUIT
+2 SET ^TMP($JOB,"PATIENTS",DFN,BUDORD)=""
+3 SET $PIECE(BUDT6("P"),U,BUDORD)=$PIECE(BUDT6("P"),U,BUDORD)+1
+4 QUIT
OT ;
+1 ;patient already a hit on this line
IF $DATA(^XTMP("BUDCRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN))
QUIT
+2 SET ^XTMP("BUDCRPT1",BUDJ,BUDH,"ORPHANS",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$EXTRACT(BUDVAL,1,20)
+3 QUIT
T6 ;EP
+1 SET BUDV=0
FOR
SET BUDV=$ORDER(^TMP($JOB,"VISITS356A",BUDV))
IF BUDV'=+BUDV
QUIT
Begin DoDot:1
+2 SET BUDP=$$PRIMPROV^APCLV(BUDV,"D")
IF BUDP=""
QUIT
+3 SET BUDIEN=0
FOR
SET BUDIEN=$ORDER(^AUPNVPOV("AD",BUDV,BUDIEN))
IF BUDIEN'=+BUDIEN
QUIT
Begin DoDot:2
+4 ;$$PRIMPOV^APCLV(BUDV,"C") Q:BUDPOV="" S BUDPOVP=$$PRIMPOV^APCLV(BUDV,"I")
SET BUDPOV=$$VAL^XBDIQ1(9000010.07,BUDIEN,.01)
SET BUDPOVP=$PIECE(^AUPNVPOV(BUDIEN,0),U,1)
+5 DO PRIMDX
End DoDot:2
End DoDot:1
SERV1 ;NOW DO SERVICES ON FULL LIST
+1 SET BUDV=0
FOR
SET BUDV=$ORDER(^TMP($JOB,"VISITSLIST",BUDV))
IF BUDV'=+BUDV
QUIT
DO SERV
+2 QUIT
PRIMDX ;
+1 SET BUDLINE=$ORDER(^BUDCTSC("AC",BUDPOVP,0))
+2 ;Q ;LORI FIX THIS LATER
IF BUDLINE=""
QUIT
+3 ;order
SET BUDORD=$PIECE(^BUDCTSC(BUDLINE,0),U,1)
+4 SET BUDVAL=BUDPOV
+5 DO PT
+6 QUIT
SERV ;
+1 SET BUDORD=30
FOR
SET BUDORD=$ORDER(^BUDCTSC("B",BUDORD))
IF BUDORD'=+BUDORD
QUIT
SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDCTSC("B",BUDORD,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:1
+2 SET BUDVAL=""
+3 ;header only
IF $PIECE(^BUDCTSC(BUDY,0),U,2)
QUIT
+4 XECUTE ^BUDCTSC(BUDY,1)
+5 IF BUDVAL=""
QUIT
+6 DO PT
End DoDot:1
+7 QUIT
MAM ;EP
+1 SET BUDVAL=$$MAMM(BUDV)
IF BUDVAL]""
QUIT
+2 IF BUDVAL=""
Begin DoDot:1
+3 SET BUDW=0
FOR
SET BUDW=$ORDER(^TMP($JOB,"MAMMS",BUDW))
IF BUDW'=+BUDW
QUIT
Begin DoDot:2
+4 SET D=$SELECT($$VERSION^XPDUTL("BW")<3:$PIECE($GET(^BWPCD(BUDW,0)),U,12),1:$PIECE(^TMP($JOB,"MAMMS",BUDW),U,3))
+5 ;pap not on this visit date
IF D'=$PIECE($PIECE($GET(^AUPNVSIT(BUDV,0)),U),".")
QUIT
+6 ;ALREADY HAVE A PAP ON THIS DATE
IF $DATA(^TMP($JOB,"MAMDATE",$PIECE($PIECE(^AUPNVSIT(BUDV,0),U),".")))
QUIT
+7 DO PT1
SET ^XTMP("BUDCRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW)=^TMP($JOB,"MAMMS",BUDW)
+8 SET ^TMP($JOB,"MAMDATE",$PIECE($PIECE($GET(^AUPNVSIT(BUDV,0)),U),"."))=""
End DoDot:2
End DoDot:1
+9 QUIT
PAP1 ;
+1 SET BUDVAL=$$PAP(BUDV)
IF BUDVAL]""
QUIT
+2 IF BUDVAL=""
Begin DoDot:1
+3 SET BUDW=0
FOR
SET BUDW=$ORDER(^TMP($JOB,"PAPS",BUDW))
IF BUDW'=+BUDW
QUIT
Begin DoDot:2
+4 SET D=$SELECT($$VERSION^XPDUTL("BW")<3:$PIECE($GET(^BWPCD(BUDW,0)),U,12),1:$PIECE(^TMP($JOB,"PAPS",BUDW),U,3))
+5 IF D'=$PIECE($PIECE($GET(^AUPNVSIT(BUDV,0)),U),".")
QUIT
+6 ;ALREADY HAVE A PAP ON THIS DATE
IF $DATA(^TMP($JOB,"PAPDATE",$PIECE($PIECE(^AUPNVSIT(BUDV,0),U),".")))
QUIT
+7 DO PT1
SET ^XTMP("BUDCRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW)=^TMP($JOB,"PAPS",BUDW)
+8 SET ^TMP($JOB,"PAPDATE",$PIECE($PIECE($GET(^AUPNVSIT(BUDV,0)),U),"."))=""
End DoDot:2
End DoDot:1
+9 QUIT
CONTRA(BUDV) ;
+1 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
SET R=$PIECE(^AUPNVPOV(X,0),U)
SET R=$PIECE($$ICDDX^ICDEX(R,$$VD^APCLV(BUDV)),U,2)
IF $EXTRACT(R,1,3)="V25"!($EXTRACT(R,1,3)="Z30")
SET G=R
+2 QUIT G
SEASFLU(BUDV) ;
+1 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+2 SET Z=$PIECE(^AUPNVCPT(X,0),U)
+3 SET Z=$PIECE($$CPT^ICPTCOD(Z),U,2)
+4 IF Z>90653
IF Z<90663
SET G=Z
QUIT
+5 IF Z>90671
IF Z<90674
SET G=Z
QUIT
+6 IF Z>90684
IF Z<90689
SET G=Z
QUIT
+7 QUIT
End DoDot:1
+8 IF G]""
QUIT "V CPT: "_G
+9 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+10 SET Z=$PIECE(^AUPNVIMM(X,0),U)
SET Z=+$PIECE(^AUTTIMM(Z,0),U,3)
+11 IF Z=15!(Z=16)!(Z=111)!(Z=88)!(Z=135)!(Z=140)!(Z=141)!(Z=144)!(Z=149)!(Z=150)!(Z=151)!(Z=153)!(Z=155)!(Z=158)!(Z=161)!(Z=166)
SET G=Z_" imm"
+12 QUIT
End DoDot:1
+13 QUIT G
+14 ;
+15 ;
PAP(BUDV) ;
+1 SET T=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+2 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
SET R=$PIECE($GET(^AUPNVLAB(X,0)),U)
IF R
IF $DATA(^ATXLAB(T,21,"B",R))
SET G=$PIECE(^LAB(60,R,0),U)
+3 IF G]""
QUIT "V LAB: "_G
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
SET R=$PIECE(^AUPNVLAB(X,0),U)
SET R=$PIECE(^LAB(60,R,0),U)
IF R="PAP SMEAR"
SET G=R
+5 IF G]""
QUIT "V LAB: "_G
+6 SET T=$ORDER(^ATXAX("B","BUD CPT PAP 10",0))
+7 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+8 SET Z=$PIECE(^AUPNVCPT(X,0),U)
+9 IF $$ICD^ATXCHK(Z,T,1)
SET G=$PIECE($$CPT^ICPTCOD(Z),U,2)
+10 QUIT
End DoDot:1
+11 IF G]""
QUIT "V CPT: "_G
+12 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVPOV("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+13 SET Z=$PIECE(^AUPNVPOV(X,0),U)
SET Z=$PIECE($$ICDDX^ICDEX(Z,$$VD^APCLV(BUDV)),U,2)
+14 ;!(Z="V72.32")!(Z="V76.47")!(Z="V67.01")!($E(Z,1,5)="795.0") S G=Z
IF Z="V76.2"!(Z="V72.3")!(Z="V72.31")!(Z="V72.32")!($EXTRACT(Z,1,6)="Z01.41")!($EXTRACT(Z,1,6)="Z01.42")!($EXTRACT(Z,1,5)="Z12.4")
SET G=Z
End DoDot:1
+15 IF G]""
QUIT "V POV: "_G
+16 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVPRC("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+17 SET Z=$$GET1^DIQ(9000010.08,X,.01)
+18 IF Z="91.46"
SET G=Z
End DoDot:1
+19 IF G]""
QUIT "V PROCEDURE: "_G
+20 SET T=$ORDER(^ATXAX("B","BGP PAP LOINC CODES",0))
+21 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+22 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
+23 IF J=""
QUIT
+24 IF '$$LOINC(J,T)
QUIT
+25 SET G=J
End DoDot:1
+26 IF G]""
QUIT "V LAB LOINC: "_G
+27 QUIT ""
IMM(BUDV) ;
+1 SET T=$ORDER(^ATXAX("B","BUD 12 CPT IMM LINE 24",0))
+2 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+3 SET Z=$PIECE(^AUPNVCPT(X,0),U)
+4 IF $$ICD^ATXCHK(Z,T,1)
SET G=$PIECE($$CPT^ICPTCOD(Z),U,2)
+5 QUIT
End DoDot:1
+6 IF G]""
QUIT "V CPT: "_G
+7 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+8 SET Z=$PIECE(^AUPNVIMM(X,0),U)
SET Z=+$PIECE(^AUTTIMM(Z,0),U,3)
+9 SET BUDTIEN=$ORDER(^BUDCCNTL("B","IMMUNIZATIONS LINE 24",0))
+10 IF $DATA(^BUDCCNTL(BUDTIEN,11,"B",Z))
SET G=Z_" imm"
+11 QUIT
End DoDot:1
+12 QUIT G
HIV(BUDV) ;EP
+1 SET T=$ORDER(^ATXLAB("B","BGP HIV TEST TAX",0))
+2 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
SET R=$PIECE($GET(^AUPNVLAB(X,0)),U)
IF R
IF $DATA(^ATXLAB(T,21,"B",R))
SET G=$PIECE(^LAB(60,R,0),U)
+3 IF G]""
QUIT "V LAB: "_G
+4 ;S T=$O(^ATXAX("B","BUD CPT HIV TESTS",0))
+5 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+6 SET Z=$PIECE(^AUPNVCPT(X,0),U)
+7 SET %=$$VAL^XBDIQ1(9000010.18,X,.01)
+8 IF %=86689!(%=86701)!(%=86702)!(%=86703)!(%=87390)!(%=87391)
SET G=$PIECE($$CPT^ICPTCOD(Z),U,2)
+9 QUIT
End DoDot:1
+10 IF G]""
QUIT "V CPT: "_G
+11 SET T=$ORDER(^ATXAX("B","BGP HIV TEST LOINC CODES",0))
+12 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
+14 IF J=""
QUIT
+15 IF '$$LOINC(J,T)
QUIT
+16 SET G=J
End DoDot:1
+17 IF G]""
QUIT "V LAB LOINC: "_G
+18 QUIT ""
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
MAMM(BUDV) ;
+1 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVRAD("AD",BUDV,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Z=$PIECE(^AUPNVRAD(X,0),U)
SET Z=$PIECE(^RAMIS(71,Z,0),U,9)
IF Z
SET Y=$PIECE($$CPT^ICPTCOD(Z),U,2)
+3 IF Y=77057!(Y=77052)
SET G=Y
End DoDot:1
+4 IF G]""
QUIT "V RAD: "_G
+5 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVPOV("AD",BUDV,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET Z=$PIECE(^AUPNVPOV(X,0),U)
SET Z=$PIECE($$ICDDX^ICDEX(Z,$$VD^APCLV(BUDV)),U,2)
+7 IF Z="V76.11"!(Z="V76.12")!($EXTRACT(Z,1,6)="Z12.31")
SET G=Z
End DoDot:1
+8 IF G]""
QUIT "V POV: "_G
+9 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 SET Z=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Z),U,2)
+11 IF Y=77057!(Y=77052)
SET G="V CPT: "_Y
End DoDot:1
+12 IF G]""
QUIT "V CPT: "_Y
+13 QUIT ""
HEPB(BUDV) ;
+1 SET T=$ORDER(^ATXLAB("B","BUD HEPATITIS B TESTS",0))
+2 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
SET R=$PIECE($GET(^AUPNVLAB(X,0)),U)
IF R
IF $DATA(^ATXLAB(T,21,"B",R))
SET G=$PIECE(^LAB(60,R,0),U)
+3 IF G]""
QUIT "V LAB: "_G
+4 SET T=$ORDER(^ATXAX("B","BUD CPT HEPATITIS B TESTS",0))
+5 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+6 SET Z=$PIECE(^AUPNVCPT(X,0),U)
+7 IF $$ICD^ATXCHK(Z,T,1)
SET G=$PIECE($$CPT^ICPTCOD(Z),U,2)
+8 QUIT
End DoDot:1
+9 IF G]""
QUIT "V CPT: "_G
+10 QUIT ""
HEPC(BUDV) ;
+1 SET T=$ORDER(^ATXLAB("B","BUD HEPATITIS C TESTS",0))
+2 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
SET R=$PIECE($GET(^AUPNVLAB(X,0)),U)
IF R
IF $DATA(^ATXLAB(T,21,"B",R))
SET G=$PIECE(^LAB(60,R,0),U)
+3 IF G]""
QUIT "V LAB: "_G
+4 SET T=$ORDER(^ATXAX("B","BUD CPT HEPATITIS C TESTS",0))
+5 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+6 SET Z=$PIECE(^AUPNVCPT(X,0),U)
+7 IF $$ICD^ATXCHK(Z,T,1)
SET G=$PIECE($$CPT^ICPTCOD(Z),U,2)
+8 QUIT
End DoDot:1
+9 IF G]""
QUIT "V CPT: "_G
+10 QUIT ""
