BUDARPC1 ; 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=26.4 C=71
S:C=24.1 C=65
S:C=24.2 C=66
S:C=4.1 C=67 ;line 4a
S:C=4.2 C=68 ;line 4b
S:C=21.1 C=69
S:C=21.2 C=70
I $G(BUDT6L) S ^XTMP("BUDARPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$G(^XTMP("BUDARPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV))_$E(BUDVAL,1,20)_U
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("BUDARPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN)) Q ;patient already a hit on this line
S ^XTMP("BUDARPT1",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 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")
..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=1 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 BUDPOV="070.20"!(BUDPOV="070.22")!(BUDPOV="070.30")!(BUDPOV="070.32") S C=4.1 S BUDVAL=BUDPOV D PT Q
I BUDPOV="070.41"!(BUDPOV="070.44")!(BUDPOV="070.51")!(BUDPOV="070.54")!(BUDPOV="070.70")!(BUDPOV="070.71") S C=4.2 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)!($E(BUDPOV,1,5)="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",BUDPOV'="V85.51",BUDPOV'="V85.52",BUDPOV'="V85.10",BUDPOV'="V85.00" 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.21 Q 1
;I C=300.22 Q 1
;I C=300.23 Q 1
;I C=300.29 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=$$HEPB(BUDV) I BUDVAL]"" S C=21.1 D PT
S BUDVAL=$$HEPC(BUDV) I BUDVAL]"" S C=21.2 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("BUDARPT1",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("BUDARPT1",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^BUDARPC2(BUDV) I BUDVAL]"" S C=26 D PT
S BUDVAL=$$L26A^BUDARPC2(BUDV) I BUDVAL]"" S C="26.1" D PT
S BUDVAL=$$L26B^BUDARPC2(BUDV) I BUDVAL]"" S C="26.2" D PT
S BUDVAL=$$L26C^BUDARPC2(BUDV) I BUDVAL]"" S C="26.3" D PT
S BUDVAL=$$L26D^BUDARPC2(BUDV) I BUDVAL]"" S C="26.4" D PT
S BUDVAL=$$L27^BUDARPC2(BUDV) I BUDVAL]"" S C=27 D PT
S BUDVAL=$$L28^BUDARPC2(BUDV) I BUDVAL]"" S C=28 D PT
S BUDVAL=$$L29^BUDARPC2(BUDV) I BUDVAL]"" S C=29 D PT
S BUDVAL=$$L30^BUDARPC2(BUDV) I BUDVAL]"" S C=30 D PT
S BUDVAL=$$L31^BUDARPC2(BUDV) I BUDVAL]"" S C=31 D PT
S BUDVAL=$$L32^BUDARPC2(BUDV) I BUDVAL]"" S C=32 D PT
S BUDVAL=$$L33^BUDARPC2(BUDV) I BUDVAL]"" S C=33 D PT
S BUDVAL=$$L34^BUDARPC2(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)!(Z=135)!(Z=140)!(Z=141)!(Z=144) 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 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^ICDCODE(Z),U,2)
.I Z="V76.2"!(Z="V72.3")!(Z="V72.31")!(Z="V72.32") 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(^BUDQCNTL("B","IMMUNIZATIONS LINE 24",0))
.I $D(^BUDQCNTL(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=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^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(^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 ""
BUDARPC1 ; 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=26.4
SET C=71
+7 IF C=24.1
SET C=65
+8 IF C=24.2
SET C=66
+9 ;line 4a
IF C=4.1
SET C=67
+10 ;line 4b
IF C=4.2
SET C=68
+11 IF C=21.1
SET C=69
+12 IF C=21.2
SET C=70
+13 IF $GET(BUDT6L)
SET ^XTMP("BUDARPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$GET(^XTMP("BUDARPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV))_$EXTRACT(BUDVAL,1,20)_U
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("BUDARPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN))
QUIT
+2 SET ^XTMP("BUDARPT1",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 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 IF $EXTRACT(BUDPOV)="."
QUIT
+6 IF $EXTRACT(BUDPOV)="E"
QUIT
+7 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 IF BUDPOV="042."!(BUDPOV="079.53")
SET C=1
SET BUDVAL=BUDPOV
DO PT
QUIT
+2 IF $EXTRACT(BUDPOV,1,3)="V08"
SET C=1
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 BUDPOV="070.20"!(BUDPOV="070.22")!(BUDPOV="070.30")!(BUDPOV="070.32")
SET C=4.1
SET BUDVAL=BUDPOV
DO PT
QUIT
+6 IF BUDPOV="070.41"!(BUDPOV="070.44")!(BUDPOV="070.51")!(BUDPOV="070.54")!(BUDPOV="070.70")!(BUDPOV="070.71")
SET C=4.2
SET BUDVAL=BUDPOV
DO PT
QUIT
+7 IF $EXTRACT(BUDPOV,1,3)=493
SET C=5
SET BUDVAL=BUDPOV
DO PT
QUIT
+8 SET X=$EXTRACT(BUDPOV,1,3)
IF X=490!(X=491)!(X=492)
SET C=6
SET BUDVAL=BUDPOV
DO PT
QUIT
+9 SET X=$EXTRACT(BUDPOV,1,3)
IF X=174!(BUDPOV=198.81)!($EXTRACT(BUDPOV,1,5)="233.0")!($EXTRACT(BUDPOV,1,5)=793.8)!($EXTRACT(BUDPOV,1,5)="238.3")
SET C=7
SET BUDVAL=BUDPOV
DO PT
QUIT
+10 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
+11 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
+12 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
+13 IF $EXTRACT(BUDPOV,1,3)>400&($EXTRACT(BUDPOV,1,3)<406)
SET C=11
SET BUDVAL=BUDPOV
DO PT
QUIT
+14 IF $EXTRACT(BUDPOV,1,3)=692
SET C=12
SET BUDVAL=BUDPOV
DO PT
QUIT
+15 IF $EXTRACT(BUDPOV,1,5)="276.5"
SET C=13
SET BUDVAL=BUDPOV
DO PT
QUIT
+16 IF $EXTRACT(BUDPOV,1,3)=991!($EXTRACT(BUDPOV,1,3)=992)
SET C=14
SET BUDVAL=BUDPOV
DO PT
QUIT
+17 IF BUDPOV="278.00"!(BUDPOV="278.01")!(BUDPOV="278.02")
SET C=14.1
SET BUDVAL=BUDPOV
DO PT
QUIT
+18 IF $EXTRACT(BUDPOV,1,3)="V85"
IF BUDPOV'="V85.51"
IF BUDPOV'="V85.52"
IF BUDPOV'="V85.10"
IF BUDPOV'="V85.00"
SET C=14.1
SET BUDVAL=BUDPOV
DO PT
QUIT
+19 IF $EXTRACT(BUDPOV,1,3)=381!($EXTRACT(BUDPOV,1,3)=382)
SET C=15
SET BUDVAL=BUDPOV
DO PT
QUIT
+20 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
+21 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
+22 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
+23 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
+24 SET C=19
SET BUDVAL=BUDPOV
DO PT
QUIT
End DoDot:1
QUIT
+25 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
+26 SET C=19
SET BUDVAL=BUDPOV
DO PT
QUIT
End DoDot:1
QUIT
+27 IF BUDPOV="305.1"
SET C=19.1
SET BUDVAL=BUDPOV
DO PT
QUIT
+28 IF $EXTRACT(BUDPOV,1,5)="357.6"!($EXTRACT(BUDPOV,1,5)="648.3")
SET C=19
SET BUDVAL=BUDPOV
DO PT
QUIT
+29 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
+30 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
+31 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
+32 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
+33 ;W !,"OOPS ",BUDPOV
+34 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 ;I C=300.21 Q 1
+5 ;I C=300.22 Q 1
+6 ;I C=300.23 Q 1
+7 ;I C=300.29 Q 1
+8 IF C=300.3
QUIT 1
+9 IF C=300.4
QUIT 1
+10 IF C=301.13
QUIT 1
+11 IF C=308.3
QUIT 1
+12 IF C=309.81
QUIT 1
+13 IF $EXTRACT(C,1,3)=311
QUIT 1
+14 IF $EXTRACT(C,1,5)="312.8"
QUIT 1
+15 IF $EXTRACT(C,1,5)="312.9"
QUIT 1
+16 IF C=313.81
QUIT 1
+17 IF $EXTRACT(C,1,3)=314
QUIT 1
+18 QUIT 0
SERV ;
+1 SET BUDVAL=$$HIV(BUDV)
IF BUDVAL]""
SET C=21
DO PT
+2 SET BUDVAL=$$HEPB(BUDV)
IF BUDVAL]""
SET C=21.1
DO PT
+3 SET BUDVAL=$$HEPC(BUDV)
IF BUDVAL]""
SET C=21.2
DO PT
+4 SET BUDVAL=$$MAMM(BUDV)
IF BUDVAL]""
SET C=22
DO PT
+5 IF BUDVAL=""
Begin DoDot:1
+6 SET BUDW=0
FOR
SET BUDW=$ORDER(^TMP($JOB,"MAMMS",BUDW))
IF BUDW'=+BUDW
QUIT
Begin DoDot:2
+7 ;S D=$P($G(^BWPCD(BUDW,0)),U,12)
+8 SET D=$SELECT($$VERSION^XPDUTL("BW")<3:$PIECE($GET(^BWPCD(BUDW,0)),U,12),1:$PIECE(^TMP($JOB,"MAMMS",BUDW),U,3))
+9 ;pap not on this visit date
IF D'=$PIECE($PIECE($GET(^AUPNVSIT(BUDV,0)),U),".")
QUIT
+10 ;ALREADY HAVE A PAP ON THIS DATE
IF $DATA(^TMP($JOB,"MAMDATE",$PIECE($PIECE(^AUPNVSIT(BUDV,0),U),".")))
QUIT
+11 SET C=22
DO PT1
SET ^XTMP("BUDARPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW)=^TMP($JOB,"MAMMS",BUDW)
+12 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("BUDARPT1",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 ;S BUDVAL=$$H1N1FLU(BUDV) I BUDVAL]"" S C=24.2 D PT
+12 SET BUDVAL=$$CONTRA(BUDV)
IF BUDVAL]""
SET C=25
DO PT
+13 SET Y=0
SET BUDVAL=$$L26^BUDARPC2(BUDV)
IF BUDVAL]""
SET C=26
DO PT
+14 SET BUDVAL=$$L26A^BUDARPC2(BUDV)
IF BUDVAL]""
SET C="26.1"
DO PT
+15 SET BUDVAL=$$L26B^BUDARPC2(BUDV)
IF BUDVAL]""
SET C="26.2"
DO PT
+16 SET BUDVAL=$$L26C^BUDARPC2(BUDV)
IF BUDVAL]""
SET C="26.3"
DO PT
+17 SET BUDVAL=$$L26D^BUDARPC2(BUDV)
IF BUDVAL]""
SET C="26.4"
DO PT
+18 SET BUDVAL=$$L27^BUDARPC2(BUDV)
IF BUDVAL]""
SET C=27
DO PT
+19 SET BUDVAL=$$L28^BUDARPC2(BUDV)
IF BUDVAL]""
SET C=28
DO PT
+20 SET BUDVAL=$$L29^BUDARPC2(BUDV)
IF BUDVAL]""
SET C=29
DO PT
+21 SET BUDVAL=$$L30^BUDARPC2(BUDV)
IF BUDVAL]""
SET C=30
DO PT
+22 SET BUDVAL=$$L31^BUDARPC2(BUDV)
IF BUDVAL]""
SET C=31
DO PT
+23 SET BUDVAL=$$L32^BUDARPC2(BUDV)
IF BUDVAL]""
SET C=32
DO PT
+24 SET BUDVAL=$$L33^BUDARPC2(BUDV)
IF BUDVAL]""
SET C=33
DO PT
+25 SET BUDVAL=$$L34^BUDARPC2(BUDV)
IF BUDVAL]""
SET C=34
DO PT
+26 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)!(Z=135)!(Z=140)!(Z=141)!(Z=144)
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 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^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")!(Z="V72.32")
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(^BUDQCNTL("B","IMMUNIZATIONS LINE 24",0))
+10 IF $DATA(^BUDQCNTL(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=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^ICDCODE(Z),U,2)
+7 IF Z="V76.11"!(Z="V76.12")
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 ""
