BUDRPTC1 ; IHS/CMI/LAB - UDS TABLE 6 ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
PT ;
I $G(BUDT6L) S ^XTMP("BUDRPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$E(BUDVAL,1,20)
S $P(BUDT6("V"),U,C)=$P(BUDT6("V"),U,C)+1
I $D(^TMP($J,"PATIENTS",DFN,C)) Q
S ^TMP($J,"PATIENTS",DFN,C)=""
S $P(BUDT6("P"),U,C)=$P(BUDT6("P"),U,C)+1
Q
OT ;
I $D(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN)) Q ;patient already a hit on this line
S ^XTMP("BUDRPT1",BUDJ,BUDH,"ORPHANS",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$E(BUDVAL,1,20)
Q
T6 ;EP
S BUDV=0 F S BUDV=$O(^TMP($J,"VISITSLIST",BUDV)) Q:BUDV'=+BUDV D
.D SERV
.S BUDP=$$PRIMPROV^APCLV(BUDV,"D") Q:BUDP=""
.S BUDPOV=$$PRIMPOV^APCLV(BUDV,"C") Q:BUDPOV="" S BUDPOVP=$$PRIMPOV^APCLV(BUDV,"I")
.Q:$E(BUDPOV)="."
.Q:$E(BUDPOV)="E"
.D PRIMDX
; now go through orphans if report is wanted
Q:'$G(BUDTOL)
S BUDV=0 F S BUDV=$O(^TMP($J,"ORPHANS",BUDV)) Q:BUDV'=+BUDV D
.S BUDVAL=$$HIV(BUDV) I BUDVAL]"" S C=21 D PT
.S BUDVAL=$$MAMM(BUDV) I BUDVAL]"" S C=22 D PT
.S BUDVAL=$$PAP(BUDV) I BUDVAL]"" S C=23 D PT
.S BUDVAL=$$IMM(BUDV) I BUDVAL]"" S C=24 D PT
.S BUDVAL=$$CONTRA(BUDV) I BUDVAL]"" S C=25 D PT
.S Y=0 S BUDVAL=$$L26(BUDV) I BUDVAL]"" S C=26 D PT
.Q
Q
PRIMDX ;
I $E(BUDPOV,1,3)="042" S C=1 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)="V08" S C=2 S BUDVAL=BUDPOV D PT Q
S X=$E(BUDPOV,1,3) I X="010"!(X="011")!(X="012")!(X="013")!(X="014")!(X="015")!(X="016")!(X="017")!(X="018") S C=3 S BUDVAL=BUDPOV D PT Q
S X=$E(BUDPOV,1,3) I X="090"!(X="091")!(X="092")!(X="093")!(X="094")!(X="095")!(X="096")!(X="097")!(X="098")!(X="099") S C=4 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)=493 S C=5 S BUDVAL=BUDPOV D PT Q
S X=$E(BUDPOV,1,3) I X=490!(X=491)!(X=492)!(X=496) S C=6 S BUDVAL=BUDPOV D PT Q
S X=$E(BUDPOV,1,3) I X=174!(BUDPOV=198.81)!($E(BUDPOV,1,5)="233.0")!(BUDPOV=793.8) S C=7 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)=180!(BUDPOV=198.82)!($E(BUDPOV,1,5)="233.1")!($E(BUDPOV,1,5)="795.0") S C=8 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)=250!($E(BUDPOV,1,5)="775.1")!(BUDPOV="790.2") S C=9 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)=391!($E(BUDPOV,1,5)="392.0")!($E(BUDPOV,1,3)>409)&($E(BUDPOV,1,3)<430) S C=10 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)>400&($E(BUDPOV,1,3)<406) S C=11 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)=692 S C=12 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,5)="276.5" S C=13 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)=991!($E(BUDPOV,1,3)=992) S C=14 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)=381!($E(BUDPOV,1,3)=382) S C=15 S BUDVAL=BUDPOV D PT Q
S T=$O(^ATXAX("B","BUD TABLE 6 LINE 16",0))
I $$ICD^ATXCHK(BUDPOVP,T,9) S C=16 S BUDVAL=BUDPOV D PT Q
S T=$O(^ATXAX("B","BUD TABLE 6 LINE 17",0))
I $$ICD^ATXCHK(BUDPOVP,T,9) S C=17 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)=303!($E(BUDPOV,1,3)=291)!($E(BUDPOV,1,5)="357.5")!($E(BUDPOV,1,5)="305.0") S C=18 S BUDVAL=BUDPOV D PT Q
S T=$O(^ATXAX("B","BUD TABLE 6 LINE 19",0))
I $$ICD^ATXCHK(BUDPOVP,T,9) S C=19 S BUDVAL=BUDPOV D PT Q
S T=$O(^ATXAX("B","BUD TABLE 6 LINE 20",0))
I $$ICD^ATXCHK(BUDPOVP,T,9) S C=20 S BUDVAL=BUDPOV D PT Q
Q
SERV ;
S BUDVAL=$$HIV(BUDV) I BUDVAL]"" S C=21 D PT
S BUDVAL=$$MAMM(BUDV) I BUDVAL]"" S C=22 D PT
S BUDVAL=$$PAP(BUDV) I BUDVAL]"" S C=23 D PT
S BUDVAL=$$IMM(BUDV) I BUDVAL]"" S C=24 D PT
S BUDVAL=$$CONTRA(BUDV) I BUDVAL]"" S C=25 D PT
S Y=0 S BUDVAL=$$L26(BUDV) I BUDVAL]"" S C=26 D PT
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^ICDCODE(Z),U,2) I $E(R,1,3)="V25" S G=R
Q G
L26(BUDV) ;
I $$AGE^AUPNPAT($P(^AUPNVSIT(BUDV,0),U,5),BUDCAD)>11 Q ""
I $$CLINIC^APCLV(BUDV,"C")=24 Q "CLIN 24"
I $$CLINIC^APCLV(BUDV,"C")=57 Q "CLIN 57"
S X=0,G="" F S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X!(G]"") S R=$P(^AUPNVPOV(X,0),U),R=$P($$ICDDX^ICDCODE(Z),U,2) I $E(R,1,3)="V20"!($E(R,1,3)="V29") S G=R
I G]"" Q G
S T=$O(^ATXAX("B","BUD L26 CPTS",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
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 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 G
S T=$O(^ATXAX("B","BUD CPT PAP 03",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 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^ICDCODE(Z),U,2)
.I Z="V76.2"!(Z="V72.3") S G=Z
I G]"" Q G
S X=0,G="" F S X=$O(^AUPNVPRC("AD",BUDV,X)) Q:X'=+X!(G]"") D
.S Z=$P(^AUPNVPRC(X,0),U),Z=$P($$ICDOP^ICDCODE(Z),U,2)
.I Z="91.46" S G=Z
I G]"" Q 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=""
.S J=$P($G(^LAB(95.3,J,9999999)),U,2)
.I $D(^ATXAX(T,21,"B",J)) S G=J
I G]"" Q G
Q ""
IMM(BUDV) ;
S T=$O(^ATXAX("B","BUD IMM CPTS",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 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(^BUDCNTL(2,11,"B",Z)) S G=Z_" imm"
.Q
Q G
HIV(BUDV) ;
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 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)
.I $$ICD^ATXCHK(Z,T,1) S G=$P($$CPT^ICPTCOD(Z),U,2)
.Q
I G]"" Q 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=""
.S J=$P($G(^LAB(95.3,J,9999999)),U,2)
.I $D(^ATXAX(T,21,"B",J)) S G=J
I G]"" Q G
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 Z=$P($$CPT^ICPTCOD(Z),U,2)
.I Z=76091!(Z=76090)!(Z=76092) S G=Z
I G]"" Q 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^ICDCODE(Z),U,2)
.I Z="V76.11"!(Z="V76.12") S G=Z
I G]"" Q G
S X=0,G="" F S X=$O(^AUPNVPRC("AD",BUDV,X)) Q:X'=+X D
.S Z=$P(^AUPNVPRC(X,0),U),Z=$P($$ICDOP^ICDCODE(Z),U,2)
.I Z="87.37"!(Z="87.36")!(Z="87.35") S G=Z
I G]"" Q G
S X=0,G="" F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X D
.S Z=$P(^AUPNVCPT(X,0),U),Z=$P($$CPT^ICPTCOD(Z),U,2)
.I Z=76091!(Z=76090)!(Z=76092) S G=Z
.Q
Q G
BUDRPTC1 ; 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("BUDRPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$EXTRACT(BUDVAL,1,20)
+2 SET $PIECE(BUDT6("V"),U,C)=$PIECE(BUDT6("V"),U,C)+1
+3 IF $DATA(^TMP($JOB,"PATIENTS",DFN,C))
QUIT
+4 SET ^TMP($JOB,"PATIENTS",DFN,C)=""
+5 SET $PIECE(BUDT6("P"),U,C)=$PIECE(BUDT6("P"),U,C)+1
+6 QUIT
OT ;
+1 ;patient already a hit on this line
IF $DATA(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN))
QUIT
+2 SET ^XTMP("BUDRPT1",BUDJ,BUDH,"ORPHANS",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$EXTRACT(BUDVAL,1,20)
+3 QUIT
T6 ;EP
+1 SET BUDV=0
FOR
SET BUDV=$ORDER(^TMP($JOB,"VISITSLIST",BUDV))
IF BUDV'=+BUDV
QUIT
Begin DoDot:1
+2 DO SERV
+3 SET BUDP=$$PRIMPROV^APCLV(BUDV,"D")
IF BUDP=""
QUIT
+4 SET BUDPOV=$$PRIMPOV^APCLV(BUDV,"C")
IF BUDPOV=""
QUIT
SET BUDPOVP=$$PRIMPOV^APCLV(BUDV,"I")
+5 IF $EXTRACT(BUDPOV)="."
QUIT
+6 IF $EXTRACT(BUDPOV)="E"
QUIT
+7 DO PRIMDX
End DoDot:1
+8 ; now go through orphans if report is wanted
+9 IF '$GET(BUDTOL)
QUIT
+10 SET BUDV=0
FOR
SET BUDV=$ORDER(^TMP($JOB,"ORPHANS",BUDV))
IF BUDV'=+BUDV
QUIT
Begin DoDot:1
+11 SET BUDVAL=$$HIV(BUDV)
IF BUDVAL]""
SET C=21
DO PT
+12 SET BUDVAL=$$MAMM(BUDV)
IF BUDVAL]""
SET C=22
DO PT
+13 SET BUDVAL=$$PAP(BUDV)
IF BUDVAL]""
SET C=23
DO PT
+14 SET BUDVAL=$$IMM(BUDV)
IF BUDVAL]""
SET C=24
DO PT
+15 SET BUDVAL=$$CONTRA(BUDV)
IF BUDVAL]""
SET C=25
DO PT
+16 SET Y=0
SET BUDVAL=$$L26(BUDV)
IF BUDVAL]""
SET C=26
DO PT
+17 QUIT
End DoDot:1
+18 QUIT
PRIMDX ;
+1 IF $EXTRACT(BUDPOV,1,3)="042"
SET C=1
SET BUDVAL=BUDPOV
DO PT
QUIT
+2 IF $EXTRACT(BUDPOV,1,3)="V08"
SET C=2
SET BUDVAL=BUDPOV
DO PT
QUIT
+3 SET X=$EXTRACT(BUDPOV,1,3)
IF X="010"!(X="011")!(X="012")!(X="013")!(X="014")!(X="015")!(X="016")!(X="017")!(X="018")
SET C=3
SET BUDVAL=BUDPOV
DO PT
QUIT
+4 SET X=$EXTRACT(BUDPOV,1,3)
IF X="090"!(X="091")!(X="092")!(X="093")!(X="094")!(X="095")!(X="096")!(X="097")!(X="098")!(X="099")
SET C=4
SET BUDVAL=BUDPOV
DO PT
QUIT
+5 IF $EXTRACT(BUDPOV,1,3)=493
SET C=5
SET BUDVAL=BUDPOV
DO PT
QUIT
+6 SET X=$EXTRACT(BUDPOV,1,3)
IF X=490!(X=491)!(X=492)!(X=496)
SET C=6
SET BUDVAL=BUDPOV
DO PT
QUIT
+7 SET X=$EXTRACT(BUDPOV,1,3)
IF X=174!(BUDPOV=198.81)!($EXTRACT(BUDPOV,1,5)="233.0")!(BUDPOV=793.8)
SET C=7
SET BUDVAL=BUDPOV
DO PT
QUIT
+8 IF $EXTRACT(BUDPOV,1,3)=180!(BUDPOV=198.82)!($EXTRACT(BUDPOV,1,5)="233.1")!($EXTRACT(BUDPOV,1,5)="795.0")
SET C=8
SET BUDVAL=BUDPOV
DO PT
QUIT
+9 IF $EXTRACT(BUDPOV,1,3)=250!($EXTRACT(BUDPOV,1,5)="775.1")!(BUDPOV="790.2")
SET C=9
SET BUDVAL=BUDPOV
DO PT
QUIT
+10 IF $EXTRACT(BUDPOV,1,3)=391!($EXTRACT(BUDPOV,1,5)="392.0")!($EXTRACT(BUDPOV,1,3)>409)&($EXTRACT(BUDPOV,1,3)<430)
SET C=10
SET BUDVAL=BUDPOV
DO PT
QUIT
+11 IF $EXTRACT(BUDPOV,1,3)>400&($EXTRACT(BUDPOV,1,3)<406)
SET C=11
SET BUDVAL=BUDPOV
DO PT
QUIT
+12 IF $EXTRACT(BUDPOV,1,3)=692
SET C=12
SET BUDVAL=BUDPOV
DO PT
QUIT
+13 IF $EXTRACT(BUDPOV,1,5)="276.5"
SET C=13
SET BUDVAL=BUDPOV
DO PT
QUIT
+14 IF $EXTRACT(BUDPOV,1,3)=991!($EXTRACT(BUDPOV,1,3)=992)
SET C=14
SET BUDVAL=BUDPOV
DO PT
QUIT
+15 IF $EXTRACT(BUDPOV,1,3)=381!($EXTRACT(BUDPOV,1,3)=382)
SET C=15
SET BUDVAL=BUDPOV
DO PT
QUIT
+16 SET T=$ORDER(^ATXAX("B","BUD TABLE 6 LINE 16",0))
+17 IF $$ICD^ATXCHK(BUDPOVP,T,9)
SET C=16
SET BUDVAL=BUDPOV
DO PT
QUIT
+18 SET T=$ORDER(^ATXAX("B","BUD TABLE 6 LINE 17",0))
+19 IF $$ICD^ATXCHK(BUDPOVP,T,9)
SET C=17
SET BUDVAL=BUDPOV
DO PT
QUIT
+20 IF $EXTRACT(BUDPOV,1,3)=303!($EXTRACT(BUDPOV,1,3)=291)!($EXTRACT(BUDPOV,1,5)="357.5")!($EXTRACT(BUDPOV,1,5)="305.0")
SET C=18
SET BUDVAL=BUDPOV
DO PT
QUIT
+21 SET T=$ORDER(^ATXAX("B","BUD TABLE 6 LINE 19",0))
+22 IF $$ICD^ATXCHK(BUDPOVP,T,9)
SET C=19
SET BUDVAL=BUDPOV
DO PT
QUIT
+23 SET T=$ORDER(^ATXAX("B","BUD TABLE 6 LINE 20",0))
+24 IF $$ICD^ATXCHK(BUDPOVP,T,9)
SET C=20
SET BUDVAL=BUDPOV
DO PT
QUIT
+25 QUIT
SERV ;
+1 SET BUDVAL=$$HIV(BUDV)
IF BUDVAL]""
SET C=21
DO PT
+2 SET BUDVAL=$$MAMM(BUDV)
IF BUDVAL]""
SET C=22
DO PT
+3 SET BUDVAL=$$PAP(BUDV)
IF BUDVAL]""
SET C=23
DO PT
+4 SET BUDVAL=$$IMM(BUDV)
IF BUDVAL]""
SET C=24
DO PT
+5 SET BUDVAL=$$CONTRA(BUDV)
IF BUDVAL]""
SET C=25
DO PT
+6 SET Y=0
SET BUDVAL=$$L26(BUDV)
IF BUDVAL]""
SET C=26
DO PT
+7 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^ICDCODE(Z),U,2)
IF $EXTRACT(R,1,3)="V25"
SET G=R
+2 QUIT G
L26(BUDV) ;
+1 IF $$AGE^AUPNPAT($PIECE(^AUPNVSIT(BUDV,0),U,5),BUDCAD)>11
QUIT ""
+2 IF $$CLINIC^APCLV(BUDV,"C")=24
QUIT "CLIN 24"
+3 IF $$CLINIC^APCLV(BUDV,"C")=57
QUIT "CLIN 57"
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVPOV("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
SET R=$PIECE(^AUPNVPOV(X,0),U)
SET R=$PIECE($$ICDDX^ICDCODE(Z),U,2)
IF $EXTRACT(R,1,3)="V20"!($EXTRACT(R,1,3)="V29")
SET G=R
+5 IF G]""
QUIT G
+6 SET T=$ORDER(^ATXAX("B","BUD L26 CPTS",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 QUIT G
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 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 G
+6 SET T=$ORDER(^ATXAX("B","BUD CPT PAP 03",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 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^ICDCODE(Z),U,2)
+14 IF Z="V76.2"!(Z="V72.3")
SET G=Z
End DoDot:1
+15 IF G]""
QUIT 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=$PIECE(^AUPNVPRC(X,0),U)
SET Z=$PIECE($$ICDOP^ICDCODE(Z),U,2)
+18 IF Z="91.46"
SET G=Z
End DoDot:1
+19 IF G]""
QUIT 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 SET J=$PIECE($GET(^LAB(95.3,J,9999999)),U,2)
+25 IF $DATA(^ATXAX(T,21,"B",J))
SET G=J
End DoDot:1
+26 IF G]""
QUIT G
+27 QUIT ""
IMM(BUDV) ;
+1 SET T=$ORDER(^ATXAX("B","BUD IMM CPTS",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 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(^BUDCNTL(2,11,"B",Z))
SET G=Z_" imm"
+10 QUIT
End DoDot:1
+11 QUIT G
HIV(BUDV) ;
+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 G
+4 SET T=$ORDER(^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 IF $$ICD^ATXCHK(Z,T,1)
SET G=$PIECE($$CPT^ICPTCOD(Z),U,2)
+8 QUIT
End DoDot:1
+9 IF G]""
QUIT G
+10 SET T=$ORDER(^ATXAX("B","BGP HIV TEST LOINC CODES",0))
+11 SET G=""
IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
+13 IF J=""
QUIT
+14 SET J=$PIECE($GET(^LAB(95.3,J,9999999)),U,2)
+15 IF $DATA(^ATXAX(T,21,"B",J))
SET G=J
End DoDot:1
+16 IF G]""
QUIT G
+17 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 Z=$PIECE($$CPT^ICPTCOD(Z),U,2)
+3 IF Z=76091!(Z=76090)!(Z=76092)
SET G=Z
End DoDot:1
+4 IF G]""
QUIT 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^ICDCODE(Z),U,2)
+7 IF Z="V76.11"!(Z="V76.12")
SET G=Z
End DoDot:1
+8 IF G]""
QUIT G
+9 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVPRC("AD",BUDV,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 SET Z=$PIECE(^AUPNVPRC(X,0),U)
SET Z=$PIECE($$ICDOP^ICDCODE(Z),U,2)
+11 IF Z="87.37"!(Z="87.36")!(Z="87.35")
SET G=Z
End DoDot:1
+12 IF G]""
QUIT G
+13 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X
QUIT
Begin DoDot:1
+14 SET Z=$PIECE(^AUPNVCPT(X,0),U)
SET Z=$PIECE($$CPT^ICPTCOD(Z),U,2)
+15 IF Z=76091!(Z=76090)!(Z=76092)
SET G=Z
+16 QUIT
End DoDot:1
+17 QUIT G
