BUDERPC1 ; IHS/CMI/LAB - UDS TABLE 6 ;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;
;
PT ;
I $G(BUDT6L) S ^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV)=$G(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,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
T6 ;EP
S BUDV=0 F S BUDV=$O(^TMP($J,"VISITSTABLE6A",BUDV)) Q:BUDV'=+BUDV D
.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)
..D DX
SERV1 ;NOW DO SERVICES ON FULL LIST
S BUDV=0 F S BUDV=$O(^TMP($J,"VISITSTABLE6A",BUDV)) Q:BUDV'=+BUDV D SERV
Q
DX ;
S BUD1="",BUDGOT="" F S BUD1=$O(^BUDETSC("AD",BUD1)) Q:BUD1=""!(BUDGOT) D
.S X=$O(^BUDETSC("AD",BUD1,0))
.Q:$G(^BUDETSC(X,1))]""
.I $$ICD^ATXCHK(BUDPOVP,$O(^ATXAX("B",BUD1,0)),9) S BUDLINE=$O(^BUDETSC("AD",BUD1,0)),BUDORD=$P(^BUDETSC(BUDLINE,0),U,1),BUDGOT=1
.Q:'BUDGOT
.Q:BUDLINE=""
.;
.S P=$$VALI^XBDIQ1(9000010,BUDV,.05)
.Q:P=""
.Q:$D(^TMP($J,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD)) ;already have this dx line for this date
.S ^TMP($J,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD)=""
.S BUDVAL=BUDPOV
.D PT
Q
SERV ;
S BUDORD=30 F S BUDORD=$O(^BUDETSC("B",BUDORD)) Q:BUDORD'=+BUDORD S BUDY=0 F S BUDY=$O(^BUDETSC("B",BUDORD,BUDY)) Q:BUDY'=+BUDY D
.S BUDVAL=""
.Q:$P(^BUDETSC(BUDY,0),U,2) ;header only
.X ^BUDETSC(BUDY,1)
.Q:BUDVAL=""
.;ALREADY HAVE THIS SERVICE FOR THIS PT ON THIS DAY?
.S P=$$VALI^XBDIQ1(9000010,BUDV,.05)
.Q:P=""
.Q:$D(^TMP($J,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD)) ;already have this dx line for this date
.S ^TMP($J,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD)=""
.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("BUDERPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,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("BUDERPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,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,I)=$P(^AUPNVPOV(X,0),U),R=$P($$ICDDX^ICDEX(R,$$VD^APCLV(BUDV)),U,2) I $$ICD^ATXCHK(I,$O(^ATXAX("B","BUD 17 T6A LINE 25",0)),9) 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 $D(^BUDETSC(BUDY,8,"B",Z)) S G=Z
.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 $D(^BUDETSC(BUDY,9,"B",Z)) 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 G="" I T S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
.I $D(^BUDETSC(BUDY,8,"B",Z)) S G=Z
.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=+^AUPNVPOV(X,0) I $$ICD^ATXCHK(Z,$O(^ATXAX("B","BUD 17 T6A LINE 23",0)),9) S G=$P($$ICDDX^ICDEX(Z),U,2)
I G]"" Q "V POV: "_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=$$VAL^XBDIQ1(9000010.18,X,.01)
.I $D(^BUDETSC(BUDY,8,"B",Z)) S G=Z
.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 $D(^BUDETSC(BUDY,9,"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 $D(^BUDETSC(BUDY,8,"B",%)) 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,$D(^BUDETSC(BUDY,8,"B",Y)) 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)
.I $$ICD^ATXCHK(Z,$O(^ATXAX("B","BUD 17 T6A LINE 22",0)),9) S G=$P(^ICD9(Z,0),U,1)
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,$D(^BUDETSC(BUDY,8,"B",Y)) 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 G="" I T S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
.I $D(^BUDETSC(BUDY,8,"B",Z)) 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=$$VAL^XBDIQ1(9000010.18,X,.01)
.I $D(^BUDETSC(BUDY,8,"B",Z)) S G=$P($$CPT^ICPTCOD(Z),U,2)
.Q
I G]"" Q "V CPT: "_G
Q ""
BUDERPC1 ; IHS/CMI/LAB - UDS TABLE 6 ;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;
+3 ;
PT ;
+1 IF $GET(BUDT6L)
SET ^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV)=$GET(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,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
T6 ;EP
+1 SET BUDV=0
FOR
SET BUDV=$ORDER(^TMP($JOB,"VISITSTABLE6A",BUDV))
IF BUDV'=+BUDV
QUIT
Begin DoDot:1
+2 SET BUDIEN=0
FOR
SET BUDIEN=$ORDER(^AUPNVPOV("AD",BUDV,BUDIEN))
IF BUDIEN'=+BUDIEN
QUIT
Begin DoDot:2
+3 SET BUDPOV=$$VAL^XBDIQ1(9000010.07,BUDIEN,.01)
SET BUDPOVP=$PIECE(^AUPNVPOV(BUDIEN,0),U,1)
+4 DO DX
End DoDot:2
End DoDot:1
SERV1 ;NOW DO SERVICES ON FULL LIST
+1 SET BUDV=0
FOR
SET BUDV=$ORDER(^TMP($JOB,"VISITSTABLE6A",BUDV))
IF BUDV'=+BUDV
QUIT
DO SERV
+2 QUIT
DX ;
+1 SET BUD1=""
SET BUDGOT=""
FOR
SET BUD1=$ORDER(^BUDETSC("AD",BUD1))
IF BUD1=""!(BUDGOT)
QUIT
Begin DoDot:1
+2 SET X=$ORDER(^BUDETSC("AD",BUD1,0))
+3 IF $GET(^BUDETSC(X,1))]""
QUIT
+4 IF $$ICD^ATXCHK(BUDPOVP,$ORDER(^ATXAX("B",BUD1,0)),9)
SET BUDLINE=$ORDER(^BUDETSC("AD",BUD1,0))
SET BUDORD=$PIECE(^BUDETSC(BUDLINE,0),U,1)
SET BUDGOT=1
+5 IF 'BUDGOT
QUIT
+6 IF BUDLINE=""
QUIT
+7 ;
+8 SET P=$$VALI^XBDIQ1(9000010,BUDV,.05)
+9 IF P=""
QUIT
+10 ;already have this dx line for this date
IF $DATA(^TMP($JOB,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD))
QUIT
+11 SET ^TMP($JOB,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD)=""
+12 SET BUDVAL=BUDPOV
+13 DO PT
End DoDot:1
+14 QUIT
SERV ;
+1 SET BUDORD=30
FOR
SET BUDORD=$ORDER(^BUDETSC("B",BUDORD))
IF BUDORD'=+BUDORD
QUIT
SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDETSC("B",BUDORD,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:1
+2 SET BUDVAL=""
+3 ;header only
IF $PIECE(^BUDETSC(BUDY,0),U,2)
QUIT
+4 XECUTE ^BUDETSC(BUDY,1)
+5 IF BUDVAL=""
QUIT
+6 ;ALREADY HAVE THIS SERVICE FOR THIS PT ON THIS DAY?
+7 SET P=$$VALI^XBDIQ1(9000010,BUDV,.05)
+8 IF P=""
QUIT
+9 ;already have this dx line for this date
IF $DATA(^TMP($JOB,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD))
QUIT
+10 SET ^TMP($JOB,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD)=""
+11 DO PT
End DoDot:1
+12 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("BUDERPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,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("BUDERPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,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,I)=$PIECE(^AUPNVPOV(X,0),U)
SET R=$PIECE($$ICDDX^ICDEX(R,$$VD^APCLV(BUDV)),U,2)
IF $$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BUD 17 T6A LINE 25",0)),9)
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 $DATA(^BUDETSC(BUDY,8,"B",Z))
SET G=Z
+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 IF $DATA(^BUDETSC(BUDY,9,"B",Z))
SET G=Z_" imm"
+10 QUIT
End DoDot:1
+11 QUIT G
+12 ;
+13 ;
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 G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+7 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
+8 IF $DATA(^BUDETSC(BUDY,8,"B",Z))
SET G=Z
+9 QUIT
End DoDot:1
+10 IF G]""
QUIT "V CPT: "_G
+11 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVPOV("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+12 SET Z=+^AUPNVPOV(X,0)
IF $$ICD^ATXCHK(Z,$ORDER(^ATXAX("B","BUD 17 T6A LINE 23",0)),9)
SET G=$PIECE($$ICDDX^ICDEX(Z),U,2)
End DoDot:1
+13 IF G]""
QUIT "V POV: "_G
+14 SET T=$ORDER(^ATXAX("B","BGP PAP LOINC CODES",0))
+15 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+16 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
+17 IF J=""
QUIT
+18 IF '$$LOINC(J,T)
QUIT
+19 SET G=J
End DoDot:1
+20 IF G]""
QUIT "V LAB LOINC: "_G
+21 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=$$VAL^XBDIQ1(9000010.18,X,.01)
+4 IF $DATA(^BUDETSC(BUDY,8,"B",Z))
SET G=Z
+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 IF $DATA(^BUDETSC(BUDY,9,"B",Z))
SET G=Z_" imm"
+10 QUIT
End DoDot:1
+11 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 $DATA(^BUDETSC(BUDY,8,"B",%))
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
IF $DATA(^BUDETSC(BUDY,8,"B",Y))
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)
+7 IF $$ICD^ATXCHK(Z,$ORDER(^ATXAX("B","BUD 17 T6A LINE 22",0)),9)
SET G=$PIECE(^ICD9(Z,0),U,1)
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
IF $DATA(^BUDETSC(BUDY,8,"B",Y))
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 G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+5 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
+6 IF $DATA(^BUDETSC(BUDY,8,"B",Z))
SET G=$PIECE($$CPT^ICPTCOD(Z),U,2)
+7 QUIT
End DoDot:1
+8 IF G]""
QUIT "V CPT: "_G
+9 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=$$VAL^XBDIQ1(9000010.18,X,.01)
+7 IF $DATA(^BUDETSC(BUDY,8,"B",Z))
SET G=$PIECE($$CPT^ICPTCOD(Z),U,2)
+8 QUIT
End DoDot:1
+9 IF G]""
QUIT "V CPT: "_G
+10 QUIT ""
