BUD9RPC1 ; IHS/CMI/LAB - UDS TABLE 6 11 Dec 2007 12:15 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
PT ;
S:C=14.1 C=60 ;THEY SCREWED ME UP HERE BY ADDING A LINE 14A
S:C=19.1 C=61
S:C=26.1 C=62
S:C=26.2 C=63
S:C=26.3 C=64
S:C=24.1 C=65
S:C=24.2 C=66
I $G(BUDT6L) S ^XTMP("BUD9RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$E(BUDVAL,1,20)
PT1 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("BUD9RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN)) Q ;patient already a hit on this line
S ^XTMP("BUD9RPT1",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,"VISITS356A",BUDV)) Q:BUDV'=+BUDV D
.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
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 ;
I BUDPOV="042."!(BUDPOV="079.53") 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) 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")!($E(BUDPOV,1,5)=793.8)!(BUDPOV="238.3") 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")!($E(BUDPOV,1,5)="648.0") 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 BUDPOV="278.00"!(BUDPOV="278.01")!(BUDPOV="278.02") S C=14.1 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)="V85",$E(BUDPOV,1,5)'="V85.0",$E(BUDPOV,1,5)'="V85.1",BUDPOV'="V85.51",BUDPOV'="V85.52" S C=14.1,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
I $E(BUDPOV,1,3)=770!($E(BUDPOV,1,3)=771)!($E(BUDPOV,1,3)>772)&($E(BUDPOV,1,3)<780),$E(BUDPOV,1,5)'="779.3" S C=16 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)>259&($E(BUDPOV,1,3)<270)!($E(BUDPOV,1,5)="779.3")!($E(BUDPOV,1,5)="783.3")!($E(BUDPOV,1,5)="783.4") 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
I $E(BUDPOV,1,5)="292.1"!($E(BUDPOV,1,5)="292.2")!($E(BUDPOV,1,5)="292.3")!($E(BUDPOV,1,5)="292.4")!($E(BUDPOV,1,5)="292.5")!($E(BUDPOV,1,5)="292.6")!($E(BUDPOV,1,5)="292.7")!($E(BUDPOV,1,5)="292.8")!($E(BUDPOV,1,3)=304) D Q
.S C=19 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,5)="305.2"!($E(BUDPOV,1,5)="305.3")!($E(BUDPOV,1,5)="305.4")!($E(BUDPOV,1,5)="305.5")!($E(BUDPOV,1,5)="305.6")!($E(BUDPOV,1,5)="305.7")!($E(BUDPOV,1,5)="305.8")!($E(BUDPOV,1,5)="305.9") D Q
.S C=19 S BUDVAL=BUDPOV D PT Q
I BUDPOV="305.1" S C=19.1,BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,5)="357.6"!($E(BUDPOV,1,5)="648.3") S C=19 S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)=296!(BUDPOV="300.4")!(BUDPOV="301.13")!($E(BUDPOV,1,3)="311") S C="40" S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,5)="300.0"!($E(BUDPOV,1,5)="300.2")!(BUDPOV="300.3")!(BUDPOV="308.3")!(BUDPOV="309.81") S C="41" S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,5)="312.8"!($E(BUDPOV,1,5)="312.9")!(BUDPOV="313.81")!($E(BUDPOV,1,3)="314") S C="42" S BUDVAL=BUDPOV D PT Q
I $E(BUDPOV,1,3)=290!($E(BUDPOV,1,3)>292)&($E(BUDPOV,1,3)<303)!($E(BUDPOV,1,3)>305&($E(BUDPOV,1,3)<320)),'$$EXCL(BUDPOV) S C="43" S BUDVAL=BUDPOV D PT Q
;W !,"OOPS ",BUDPOV
Q
EXCL(C) ;
I $E(C,1,3)=296 Q 1
I $E(C,1,5)="300.0" Q 1
I $E(C,1,5)="300.2" Q 1
I C=300.3 Q 1
I C=300.4 Q 1
I C=301.13 Q 1
I C=308.3 Q 1
I C=309.81 Q 1
I $E(C,1,3)=311 Q 1
I $E(C,1,5)="312.8" Q 1
I $E(C,1,5)="312.9" Q 1
I C=313.81 Q 1
I $E(C,1,3)=314 Q 1
Q 0
SERV ;
S BUDVAL=$$HIV(BUDV) I BUDVAL]"" S C=21 D PT
S BUDVAL=$$MAMM(BUDV) I BUDVAL]"" S C=22 D PT
I BUDVAL="" D
.S BUDW=0 F S BUDW=$O(^TMP($J,"MAMMS",BUDW)) Q:BUDW'=+BUDW D
..;S D=$P($G(^BWPCD(BUDW,0)),U,12)
..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
..S C=22 D PT1 S ^XTMP("BUD9RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW)=^TMP($J,"MAMMS",BUDW)
..S ^TMP($J,"MAMDATE",$P($P($G(^AUPNVSIT(BUDV,0)),U),"."))=""
PAP1 S BUDVAL=$$PAP(BUDV) I BUDVAL]"" S C=23 D PT
I BUDVAL="" D
.S BUDW=0 F S BUDW=$O(^TMP($J,"PAPS",BUDW)) Q:BUDW'=+BUDW D
..;S D=$P($G(^BWPCD(BUDW,0)),U,12)
..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
..S C=23 D PT1 S ^XTMP("BUD9RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW)=^TMP($J,"PAPS",BUDW)
..S ^TMP($J,"PAPDATE",$P($P($G(^AUPNVSIT(BUDV,0)),U),"."))=""
S BUDVAL=$$IMM(BUDV) I BUDVAL]"" S C=24 D PT
S BUDVAL=$$SEASFLU(BUDV) I BUDVAL]"" S C=24.1 D PT
S BUDVAL=$$H1N1FLU(BUDV) I BUDVAL]"" S C=24.2 D PT
S BUDVAL=$$CONTRA(BUDV) I BUDVAL]"" S C=25 D PT
S Y=0 S BUDVAL=$$L26^BUD9RPC2(BUDV) I BUDVAL]"" S C=26 D PT
S BUDVAL=$$L26A^BUD9RPC2(BUDV) I BUDVAL]"" S C="26.1" D PT
S BUDVAL=$$L26B^BUD9RPC2(BUDV) I BUDVAL]"" S C="26.2" D PT
S BUDVAL=$$L26C^BUD9RPC2(BUDV) I BUDVAL]"" S C="26.3" D PT
S BUDVAL=$$L27^BUD9RPC2(BUDV) I BUDVAL]"" S C=27 D PT
S BUDVAL=$$L28^BUD9RPC2(BUDV) I BUDVAL]"" S C=28 D PT
S BUDVAL=$$L29^BUD9RPC2(BUDV) I BUDVAL]"" S C=29 D PT
S BUDVAL=$$L30^BUD9RPC2(BUDV) I BUDVAL]"" S C=30 D PT
S BUDVAL=$$L31^BUD9RPC2(BUDV) I BUDVAL]"" S C=31 D PT
S BUDVAL=$$L32^BUD9RPC2(BUDV) I BUDVAL]"" S C=32 D PT
S BUDVAL=$$L33^BUD9RPC2(BUDV) I BUDVAL]"" S C=33 D PT
S BUDVAL=$$L34^BUD9RPC2(BUDV) I BUDVAL]"" S C=34 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(R),U,2) I $E(R,1,3)="V25" 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>90654,Z<90663 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) S G=Z_" imm"
.Q
Q G
H1N1FLU(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=90663!(Z=90470) 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=125!(Z=126)!(Z=127)!(Z=128) 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 09",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^ICDCODE(Z),U,2)
.I Z="V76.2"!(Z="V72.3")!(Z="V72.31") 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=$P(^AUPNVPRC(X,0),U),Z=$P($$ICDOP^ICDCODE(Z),U,2)
;.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 09 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(^BUDNCNTL("B","IMMUNIZATIONS LINE 24",0))
.I $D(^BUDNCNTL(BUDTIEN,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 "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=77052!(Y=77057) S G=Y
.;I $$ICD^ATXCHK(Z,$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1) 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^ICDCODE(Z),U,2)
.I Z="V76.11"!(Z="V76.12") S G=Z
I G]"" Q "V POV: "_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") S G=Z
;I G]"" Q "V PROC: "_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=77052!(Y=77057) S G="V CPT: "_Y
.;I $$ICD^ATXCHK(Z,$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1) S G=Y
I G]"" Q "V CPT: "_Y
Q ""
BUD9RPC1 ; IHS/CMI/LAB - UDS TABLE 6 11 Dec 2007 12:15 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
PT ;
+1 ;THEY SCREWED ME UP HERE BY ADDING A LINE 14A
IF C=14.1
SET C=60
+2 IF C=19.1
SET C=61
+3 IF C=26.1
SET C=62
+4 IF C=26.2
SET C=63
+5 IF C=26.3
SET C=64
+6 IF C=24.1
SET C=65
+7 IF C=24.2
SET C=66
+8 IF $GET(BUDT6L)
SET ^XTMP("BUD9RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$EXTRACT(BUDVAL,1,20)
PT1 SET $PIECE(BUDT6("V"),U,C)=$PIECE(BUDT6("V"),U,C)+1
+1 IF $DATA(^TMP($JOB,"PATIENTS",DFN,C))
QUIT
+2 SET ^TMP($JOB,"PATIENTS",DFN,C)=""
+3 SET $PIECE(BUDT6("P"),U,C)=$PIECE(BUDT6("P"),U,C)+1
+4 QUIT
OT ;
+1 ;patient already a hit on this line
IF $DATA(^XTMP("BUD9RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN))
QUIT
+2 SET ^XTMP("BUD9RPT1",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,"VISITS356A",BUDV))
IF BUDV'=+BUDV
QUIT
Begin DoDot:1
+2 SET BUDP=$$PRIMPROV^APCLV(BUDV,"D")
IF BUDP=""
QUIT
+3 SET BUDPOV=$$PRIMPOV^APCLV(BUDV,"C")
IF BUDPOV=""
QUIT
SET BUDPOVP=$$PRIMPOV^APCLV(BUDV,"I")
+4 IF $EXTRACT(BUDPOV)="."
QUIT
+5 IF $EXTRACT(BUDPOV)="E"
QUIT
+6 DO PRIMDX
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 IF BUDPOV="042."!(BUDPOV="079.53")
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)
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")!($EXTRACT(BUDPOV,1,5)=793.8)!(BUDPOV="238.3")
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")!($EXTRACT(BUDPOV,1,5)="648.0")
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 BUDPOV="278.00"!(BUDPOV="278.01")!(BUDPOV="278.02")
SET C=14.1
SET BUDVAL=BUDPOV
DO PT
QUIT
+16 IF $EXTRACT(BUDPOV,1,3)="V85"
IF $EXTRACT(BUDPOV,1,5)'="V85.0"
IF $EXTRACT(BUDPOV,1,5)'="V85.1"
IF BUDPOV'="V85.51"
IF BUDPOV'="V85.52"
SET C=14.1
SET BUDVAL=BUDPOV
DO PT
QUIT
+17 IF $EXTRACT(BUDPOV,1,3)=381!($EXTRACT(BUDPOV,1,3)=382)
SET C=15
SET BUDVAL=BUDPOV
DO PT
QUIT
+18 IF $EXTRACT(BUDPOV,1,3)=770!($EXTRACT(BUDPOV,1,3)=771)!($EXTRACT(BUDPOV,1,3)>772)&($EXTRACT(BUDPOV,1,3)<780)
IF $EXTRACT(BUDPOV,1,5)'="779.3"
SET C=16
SET BUDVAL=BUDPOV
DO PT
QUIT
+19 IF $EXTRACT(BUDPOV,1,3)>259&($EXTRACT(BUDPOV,1,3)<270)!($EXTRACT(BUDPOV,1,5)="779.3")!($EXTRACT(BUDPOV,1,5)="783.3")!($EXTRACT(BUDPOV,1,5)="783.4")
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 IF $EXTRACT(BUDPOV,1,5)="292.1"!($EXTRACT(BUDPOV,1,5)="292.2")!($EXTRACT(BUDPOV,1,5)="292.3")!($EXTRACT(BUDPOV,1,5)="292.4")!($EXTRACT(BUDPOV,1,5)="292.5")!(...
... $EXTRACT(BUDPOV,1,5)="292.6")!($EXTRACT(BUDPOV,1,5)="292.7")!($EXTRACT(BUDPOV,1,5)="292.8")!($EXTRACT(BUDPOV,1,3)=304)
Begin DoDot:1
+22 SET C=19
SET BUDVAL=BUDPOV
DO PT
QUIT
End DoDot:1
QUIT
+23 IF $EXTRACT(BUDPOV,1,5)="305.2"!($EXTRACT(BUDPOV,1,5)="305.3")!($EXTRACT(BUDPOV,1,5)="305.4")!($EXTRACT(BUDPOV,1,5)="305.5")!($EXTRACT(BUDPOV,1,5)="305.6")!($EXTRACT(BUDPOV,1,5)="305.7")!($EXTRACT(BUDPOV,1,5)="305.8")!($EXTRACT(BUDPOV,1,5)="305
.9")
Begin DoDot:1
+24 SET C=19
SET BUDVAL=BUDPOV
DO PT
QUIT
End DoDot:1
QUIT
+25 IF BUDPOV="305.1"
SET C=19.1
SET BUDVAL=BUDPOV
DO PT
QUIT
+26 IF $EXTRACT(BUDPOV,1,5)="357.6"!($EXTRACT(BUDPOV,1,5)="648.3")
SET C=19
SET BUDVAL=BUDPOV
DO PT
QUIT
+27 IF $EXTRACT(BUDPOV,1,3)=296!(BUDPOV="300.4")!(BUDPOV="301.13")!($EXTRACT(BUDPOV,1,3)="311")
SET C="40"
SET BUDVAL=BUDPOV
DO PT
QUIT
+28 IF $EXTRACT(BUDPOV,1,5)="300.0"!($EXTRACT(BUDPOV,1,5)="300.2")!(BUDPOV="300.3")!(BUDPOV="308.3")!(BUDPOV="309.81")
SET C="41"
SET BUDVAL=BUDPOV
DO PT
QUIT
+29 IF $EXTRACT(BUDPOV,1,5)="312.8"!($EXTRACT(BUDPOV,1,5)="312.9")!(BUDPOV="313.81")!($EXTRACT(BUDPOV,1,3)="314")
SET C="42"
SET BUDVAL=BUDPOV
DO PT
QUIT
+30 IF $EXTRACT(BUDPOV,1,3)=290!($EXTRACT(BUDPOV,1,3)>292)&($EXTRACT(BUDPOV,1,3)<303)!($EXTRACT(BUDPOV,1,3)>305&($EXTRACT(BUDPOV,1,3)<320))
IF '$$EXCL(BUDPOV)
SET C="43"
SET BUDVAL=BUDPOV
DO PT
QUIT
+31 ;W !,"OOPS ",BUDPOV
+32 QUIT
EXCL(C) ;
+1 IF $EXTRACT(C,1,3)=296
QUIT 1
+2 IF $EXTRACT(C,1,5)="300.0"
QUIT 1
+3 IF $EXTRACT(C,1,5)="300.2"
QUIT 1
+4 IF C=300.3
QUIT 1
+5 IF C=300.4
QUIT 1
+6 IF C=301.13
QUIT 1
+7 IF C=308.3
QUIT 1
+8 IF C=309.81
QUIT 1
+9 IF $EXTRACT(C,1,3)=311
QUIT 1
+10 IF $EXTRACT(C,1,5)="312.8"
QUIT 1
+11 IF $EXTRACT(C,1,5)="312.9"
QUIT 1
+12 IF C=313.81
QUIT 1
+13 IF $EXTRACT(C,1,3)=314
QUIT 1
+14 QUIT 0
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 IF BUDVAL=""
Begin DoDot:1
+4 SET BUDW=0
FOR
SET BUDW=$ORDER(^TMP($JOB,"MAMMS",BUDW))
IF BUDW'=+BUDW
QUIT
Begin DoDot:2
+5 ;S D=$P($G(^BWPCD(BUDW,0)),U,12)
+6 SET D=$SELECT($$VERSION^XPDUTL("BW")<3:$PIECE($GET(^BWPCD(BUDW,0)),U,12),1:$PIECE(^TMP($JOB,"MAMMS",BUDW),U,3))
+7 ;pap not on this visit date
IF D'=$PIECE($PIECE($GET(^AUPNVSIT(BUDV,0)),U),".")
QUIT
+8 ;ALREADY HAVE A PAP ON THIS DATE
IF $DATA(^TMP($JOB,"MAMDATE",$PIECE($PIECE(^AUPNVSIT(BUDV,0),U),".")))
QUIT
+9 SET C=22
DO PT1
SET ^XTMP("BUD9RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW)=^TMP($JOB,"MAMMS",BUDW)
+10 SET ^TMP($JOB,"MAMDATE",$PIECE($PIECE($GET(^AUPNVSIT(BUDV,0)),U),"."))=""
End DoDot:2
End DoDot:1
PAP1 SET BUDVAL=$$PAP(BUDV)
IF BUDVAL]""
SET C=23
DO PT
+1 IF BUDVAL=""
Begin DoDot:1
+2 SET BUDW=0
FOR
SET BUDW=$ORDER(^TMP($JOB,"PAPS",BUDW))
IF BUDW'=+BUDW
QUIT
Begin DoDot:2
+3 ;S D=$P($G(^BWPCD(BUDW,0)),U,12)
+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 SET C=23
DO PT1
SET ^XTMP("BUD9RPT1",BUDJ,BUDH,"T6",C,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 SET BUDVAL=$$IMM(BUDV)
IF BUDVAL]""
SET C=24
DO PT
+10 SET BUDVAL=$$SEASFLU(BUDV)
IF BUDVAL]""
SET C=24.1
DO PT
+11 SET BUDVAL=$$H1N1FLU(BUDV)
IF BUDVAL]""
SET C=24.2
DO PT
+12 SET BUDVAL=$$CONTRA(BUDV)
IF BUDVAL]""
SET C=25
DO PT
+13 SET Y=0
SET BUDVAL=$$L26^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C=26
DO PT
+14 SET BUDVAL=$$L26A^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C="26.1"
DO PT
+15 SET BUDVAL=$$L26B^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C="26.2"
DO PT
+16 SET BUDVAL=$$L26C^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C="26.3"
DO PT
+17 SET BUDVAL=$$L27^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C=27
DO PT
+18 SET BUDVAL=$$L28^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C=28
DO PT
+19 SET BUDVAL=$$L29^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C=29
DO PT
+20 SET BUDVAL=$$L30^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C=30
DO PT
+21 SET BUDVAL=$$L31^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C=31
DO PT
+22 SET BUDVAL=$$L32^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C=32
DO PT
+23 SET BUDVAL=$$L33^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C=33
DO PT
+24 SET BUDVAL=$$L34^BUD9RPC2(BUDV)
IF BUDVAL]""
SET C=34
DO PT
+25 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(R),U,2)
IF $EXTRACT(R,1,3)="V25"
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>90654
IF Z<90663
SET G=Z
QUIT
+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 Z=15!(Z=16)!(Z=111)
SET G=Z_" imm"
+10 QUIT
End DoDot:1
+11 QUIT G
H1N1FLU(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=90663!(Z=90470)
SET G=Z
QUIT
+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 Z=125!(Z=126)!(Z=127)!(Z=128)
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 T=$ORDER(^ATXAX("B","BUD CPT PAP 09",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^ICDCODE(Z),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")
SET G=Z
End DoDot:1
+15 IF G]""
QUIT "V POV: "_G
+16 ;S X=0,G="" F S X=$O(^AUPNVPRC("AD",BUDV,X)) Q:X'=+X!(G]"") D
+17 ;.S Z=$P(^AUPNVPRC(X,0),U),Z=$P($$ICDOP^ICDCODE(Z),U,2)
+18 ;.I Z="91.46" S G=Z
+19 ;I G]"" Q "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 09 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(^BUDNCNTL("B","IMMUNIZATIONS LINE 24",0))
+10 IF $DATA(^BUDNCNTL(BUDTIEN,11,"B",Z))
SET G=Z_" imm"
+11 QUIT
End DoDot:1
+12 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 "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=77052!(Y=77057)
SET G=Y
+4 ;I $$ICD^ATXCHK(Z,$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1) S G=Y
End DoDot:1
+5 IF G]""
QUIT "V RAD: "_G
+6 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVPOV("AD",BUDV,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET Z=$PIECE(^AUPNVPOV(X,0),U)
SET Z=$PIECE($$ICDDX^ICDCODE(Z),U,2)
+8 IF Z="V76.11"!(Z="V76.12")
SET G=Z
End DoDot:1
+9 IF G]""
QUIT "V POV: "_G
+10 ;S X=0,G="" F S X=$O(^AUPNVPRC("AD",BUDV,X)) Q:X'=+X D
+11 ;.S Z=$P(^AUPNVPRC(X,0),U),Z=$P($$ICDOP^ICDCODE(Z),U,2)
+12 ;.I Z="87.37"!(Z="87.36") S G=Z
+13 ;I G]"" Q "V PROC: "_G
+14 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X
QUIT
Begin DoDot:1
+15 SET Z=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Z),U,2)
+16 IF Y=77052!(Y=77057)
SET G="V CPT: "_Y
+17 ;I $$ICD^ATXCHK(Z,$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1) S G=Y
End DoDot:1
+18 IF G]""
QUIT "V CPT: "_Y
+19 QUIT ""
