BUD8RPC1 ; 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 ;
I $G(BUDT6L) S ^XTMP("BUD8RPT1",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("BUD8RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN)) Q ;patient already a hit on this line
S ^XTMP("BUD8RPT1",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,"VISITS6DX",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 $E(BUDPOV,1,3)="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) 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") 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
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 $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"!(BUDPOV="300.21")!(BUDPOV="300.22")!(BUDPOV="300.23")!(BUDPOV="300.29")!(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 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=$$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("BUD8RPT1",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("BUD8RPT1",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=$$CONTRA(BUDV) I BUDVAL]"" S C=25 D PT
S Y=0 S BUDVAL=$$L26(BUDV) I BUDVAL]"" S C=26 D PT
S BUDVAL=$$L27(BUDV) I BUDVAL]"" S C=27 D PT
S BUDVAL=$$L28(BUDV) I BUDVAL]"" S C=28 D PT
S BUDVAL=$$L29(BUDV) I BUDVAL]"" S C=29 D PT
S BUDVAL=$$L30(BUDV) I BUDVAL]"" S C=30 D PT
S BUDVAL=$$L31(BUDV) I BUDVAL]"" S C=31 D PT
S BUDVAL=$$L32(BUDV) I BUDVAL]"" S C=32 D PT
S BUDVAL=$$L33(BUDV) I BUDVAL]"" S C=33 D PT
S BUDVAL=$$L34(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
L27(BUDV) ;
I '$D(^AUPNVDEN("AD",BUDV)) Q ""
S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
.S A=$P($G(^AUPNVDEN(V,0)),U)
.Q:'A
.S A=$P($G(^AUTTADA(A,0)),U)
.Q:A=""
.I A=9110 S G=A
.Q
Q G
L28(BUDV) ;
I '$D(^AUPNVDEN("AD",BUDV)) Q ""
S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
.S A=$P($G(^AUPNVDEN(V,0)),U)
.Q:'A
.S A=$P($G(^AUTTADA(A,0)),U)
.Q:A=""
.I A="0150"!(A="0120")!(A="0140")!(A="0160")!(A="0170")!(A="0180")!(A="0145") S G=A
.Q
Q G
L29(BUDV) ;
I '$D(^AUPNVDEN("AD",BUDV)) Q ""
S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
.S A=$P($G(^AUPNVDEN(V,0)),U)
.Q:'A
.S A=$P($G(^AUTTADA(A,0)),U)
.Q:A=""
.I A=1110!(A=1120) S G=A
.Q
Q G
L30(BUDV) ;
I '$D(^AUPNVDEN("AD",BUDV)) Q ""
S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
.S A=$P($G(^AUPNVDEN(V,0)),U)
.Q:'A
.S A=$P($G(^AUTTADA(A,0)),U)
.Q:A=""
.I A=1351 S G=A
.Q
Q G
L31(BUDV) ;
S G=""
I '$D(^AUPNVDEN("AD",BUDV)) G L31POV
S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
.S A=$P($G(^AUPNVDEN(V,0)),U)
.Q:'A
.S A=$P($G(^AUTTADA(A,0)),U)
.Q:A=""
.I A=1203!(A=1201)!(A=1204)!(A=1205)!(A=1206) S G=A
.Q
I G]"" Q G
L31POV ;
S G=""
S V=0 F S V=$O(^AUPNVPOV("AD",BUDV,V)) Q:V'=+V!(G]"") D
.S A=$P($G(^AUPNVPOV(V,0)),U)
.Q:'A
.S A=$P($$ICDDX^ICDCODE(A),U,2)
.I A="V07.31" S G=A
.Q
Q G
L32(BUDV) ;
I '$D(^AUPNVDEN("AD",BUDV)) Q ""
S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
.S A=$P($G(^AUPNVDEN(V,0)),U)
.Q:'A
.S A=$P($G(^AUTTADA(A,0)),U)
.Q:A=""
.I $E(A,1,2)=21!($E(A,1,2)=23)!($E(A,1,2)=27) S G=A
.Q
Q G
L33(BUDV) ;
I '$D(^AUPNVDEN("AD",BUDV)) Q ""
S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
.S A=$P($G(^AUPNVDEN(V,0)),U)
.Q:'A
.S A=$P($G(^AUTTADA(A,0)),U)
.Q:A=""
.I A=7111!(A=7140)!(A=7210)!(A=7220)!(A=7230)!(A=7240)!(A=7241)!(A=7250)!(A=7260)!(A=7261)!(A=7270)!(A=7272)!(A=7280) S G=A
.Q
Q G
L34(BUDV) ;
I '$D(^AUPNVDEN("AD",BUDV)) Q ""
S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
.S A=$P($G(^AUPNVDEN(V,0)),U)
.Q:'A
.S A=$P($G(^AUTTADA(A,0)),U)
.Q:A=""
.I $E(A)=3!($E(A)=4)!($E(A)=5)!($E(A)=6)!($E(A)=8) S G=A
.Q
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(R),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 "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 08",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")!(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 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 "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(^BUDGCNTL("B","IMMUNIZATIONS LINE 24",0))
.I $D(^BUDGCNTL(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)
.I $$ICD^ATXCHK(Z,T,1) 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 Z=76091!(Z=76090)!(Z=76092)!(Z="G0202")!(Z="G0204")!(Z="G0206")!(Z=77055)!(Z=77056)!(Z=77057)!(Z=77058)!(Z=77059) S G=Z
.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")!(Z="793.80")!(Z=793.81)!(Z=793.89) 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 Z=76091!(Z=76090)!(Z=76092)!(Z="G0202")!(Z="G0204")!(Z="G0206")!(Z=77055)!(Z=77056)!(Z=77057)!(Z=77058)!(Z=77059) S G="V CPT: "_Z
.I $$ICD^ATXCHK(Z,$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1) S G=Y
I G Q "V CPT: "_Y
Q ""
TEST ;
S X=$$MAMM(28797)
Q
BUD8RPC1 ; 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 IF $GET(BUDT6L)
SET ^XTMP("BUD8RPT1",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("BUD8RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN))
QUIT
+2 SET ^XTMP("BUD8RPT1",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,"VISITS6DX",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 $EXTRACT(BUDPOV,1,3)="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)
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")
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 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
+17 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
+18 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
+19 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
+20 SET C=19
SET BUDVAL=BUDPOV
DO PT
QUIT
End DoDot:1
QUIT
+21 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
+22 SET C=19
SET BUDVAL=BUDPOV
DO PT
QUIT
End DoDot:1
QUIT
+23 IF $EXTRACT(BUDPOV,1,5)="357.6"!($EXTRACT(BUDPOV,1,5)="648.3")
SET C=19
SET BUDVAL=BUDPOV
DO PT
QUIT
+24 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
+25 IF $EXTRACT(BUDPOV,1,5)="300.0"!(BUDPOV="300.21")!(BUDPOV="300.22")!(BUDPOV="300.23")!(BUDPOV="300.29")!(BUDPOV="300.3")!(BUDPOV="308.3")!(BUDPOV="309.81")
SET C="41"
SET BUDVAL=BUDPOV
DO PT
QUIT
+26 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
+27 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
+28 ;W !,"OOPS ",BUDPOV
+29 QUIT
EXCL(C) ;
+1 IF $EXTRACT(C,1,3)=296
QUIT 1
+2 IF $EXTRACT(C,1,5)="300.0"
QUIT 1
+3 IF C=300.21
QUIT 1
+4 IF C=300.22
QUIT 1
+5 IF C=300.23
QUIT 1
+6 IF C=300.29
QUIT 1
+7 IF C=300.3
QUIT 1
+8 IF C=300.4
QUIT 1
+9 IF C=301.13
QUIT 1
+10 IF C=308.3
QUIT 1
+11 IF C=309.81
QUIT 1
+12 IF $EXTRACT(C,1,3)=311
QUIT 1
+13 IF $EXTRACT(C,1,5)="312.8"
QUIT 1
+14 IF $EXTRACT(C,1,5)="312.9"
QUIT 1
+15 IF C=313.81
QUIT 1
+16 IF $EXTRACT(C,1,3)=314
QUIT 1
+17 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("BUD8RPT1",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("BUD8RPT1",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=$$CONTRA(BUDV)
IF BUDVAL]""
SET C=25
DO PT
+11 SET Y=0
SET BUDVAL=$$L26(BUDV)
IF BUDVAL]""
SET C=26
DO PT
+12 SET BUDVAL=$$L27(BUDV)
IF BUDVAL]""
SET C=27
DO PT
+13 SET BUDVAL=$$L28(BUDV)
IF BUDVAL]""
SET C=28
DO PT
+14 SET BUDVAL=$$L29(BUDV)
IF BUDVAL]""
SET C=29
DO PT
+15 SET BUDVAL=$$L30(BUDV)
IF BUDVAL]""
SET C=30
DO PT
+16 SET BUDVAL=$$L31(BUDV)
IF BUDVAL]""
SET C=31
DO PT
+17 SET BUDVAL=$$L32(BUDV)
IF BUDVAL]""
SET C=32
DO PT
+18 SET BUDVAL=$$L33(BUDV)
IF BUDVAL]""
SET C=33
DO PT
+19 SET BUDVAL=$$L34(BUDV)
IF BUDVAL]""
SET C=34
DO PT
+20 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
L27(BUDV) ;
+1 IF '$DATA(^AUPNVDEN("AD",BUDV))
QUIT ""
+2 SET V=0
SET G=""
FOR
SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+3 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
+4 IF 'A
QUIT
+5 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
+6 IF A=""
QUIT
+7 IF A=9110
SET G=A
+8 QUIT
End DoDot:1
+9 QUIT G
L28(BUDV) ;
+1 IF '$DATA(^AUPNVDEN("AD",BUDV))
QUIT ""
+2 SET V=0
SET G=""
FOR
SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+3 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
+4 IF 'A
QUIT
+5 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
+6 IF A=""
QUIT
+7 IF A="0150"!(A="0120")!(A="0140")!(A="0160")!(A="0170")!(A="0180")!(A="0145")
SET G=A
+8 QUIT
End DoDot:1
+9 QUIT G
L29(BUDV) ;
+1 IF '$DATA(^AUPNVDEN("AD",BUDV))
QUIT ""
+2 SET V=0
SET G=""
FOR
SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+3 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
+4 IF 'A
QUIT
+5 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
+6 IF A=""
QUIT
+7 IF A=1110!(A=1120)
SET G=A
+8 QUIT
End DoDot:1
+9 QUIT G
L30(BUDV) ;
+1 IF '$DATA(^AUPNVDEN("AD",BUDV))
QUIT ""
+2 SET V=0
SET G=""
FOR
SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+3 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
+4 IF 'A
QUIT
+5 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
+6 IF A=""
QUIT
+7 IF A=1351
SET G=A
+8 QUIT
End DoDot:1
+9 QUIT G
L31(BUDV) ;
+1 SET G=""
+2 IF '$DATA(^AUPNVDEN("AD",BUDV))
GOTO L31POV
+3 SET V=0
SET G=""
FOR
SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+4 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
+5 IF 'A
QUIT
+6 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
+7 IF A=""
QUIT
+8 IF A=1203!(A=1201)!(A=1204)!(A=1205)!(A=1206)
SET G=A
+9 QUIT
End DoDot:1
+10 IF G]""
QUIT G
L31POV ;
+1 SET G=""
+2 SET V=0
FOR
SET V=$ORDER(^AUPNVPOV("AD",BUDV,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+3 SET A=$PIECE($GET(^AUPNVPOV(V,0)),U)
+4 IF 'A
QUIT
+5 SET A=$PIECE($$ICDDX^ICDCODE(A),U,2)
+6 IF A="V07.31"
SET G=A
+7 QUIT
End DoDot:1
+8 QUIT G
L32(BUDV) ;
+1 IF '$DATA(^AUPNVDEN("AD",BUDV))
QUIT ""
+2 SET V=0
SET G=""
FOR
SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+3 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
+4 IF 'A
QUIT
+5 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
+6 IF A=""
QUIT
+7 IF $EXTRACT(A,1,2)=21!($EXTRACT(A,1,2)=23)!($EXTRACT(A,1,2)=27)
SET G=A
+8 QUIT
End DoDot:1
+9 QUIT G
L33(BUDV) ;
+1 IF '$DATA(^AUPNVDEN("AD",BUDV))
QUIT ""
+2 SET V=0
SET G=""
FOR
SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+3 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
+4 IF 'A
QUIT
+5 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
+6 IF A=""
QUIT
+7 IF A=7111!(A=7140)!(A=7210)!(A=7220)!(A=7230)!(A=7240)!(A=7241)!(A=7250)!(A=7260)!(A=7261)!(A=7270)!(A=7272)!(A=7280)
SET G=A
+8 QUIT
End DoDot:1
+9 QUIT G
L34(BUDV) ;
+1 IF '$DATA(^AUPNVDEN("AD",BUDV))
QUIT ""
+2 SET V=0
SET G=""
FOR
SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
IF V'=+V!(G]"")
QUIT
Begin DoDot:1
+3 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
+4 IF 'A
QUIT
+5 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
+6 IF A=""
QUIT
+7 IF $EXTRACT(A)=3!($EXTRACT(A)=4)!($EXTRACT(A)=5)!($EXTRACT(A)=6)!($EXTRACT(A)=8)
SET G=A
+8 QUIT
End DoDot:1
+9 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(R),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 "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 08",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 IF Z="V76.2"!(Z="V72.3")!(Z="V72.31")!(Z="V72.32")!(Z="V76.47")!(Z="V67.01")!($EXTRACT(Z,1,5)="795.0")
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=$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 "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 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 "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(^BUDGCNTL("B","IMMUNIZATIONS LINE 24",0))
+10 IF $DATA(^BUDGCNTL(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 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 "V CPT: "_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 IF '$$LOINC(J,T)
QUIT
+15 SET G=J
End DoDot:1
+16 IF G]""
QUIT "V LAB LOINC: "_G
+17 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 ;I Z=76091!(Z=76090)!(Z=76092)!(Z="G0202")!(Z="G0204")!(Z="G0206")!(Z=77055)!(Z=77056)!(Z=77057)!(Z=77058)!(Z=77059) S G=Z
+4 IF $$ICD^ATXCHK(Z,$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1)
SET 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")!(Z="793.80")!(Z=793.81)!(Z=793.89)
SET G=Z
End DoDot:1
+9 IF G]""
QUIT "V POV: "_G
+10 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNVPRC("AD",BUDV,X))
IF X'=+X
QUIT
Begin DoDot:1
+11 SET Z=$PIECE(^AUPNVPRC(X,0),U)
SET Z=$PIECE($$ICDOP^ICDCODE(Z),U,2)
+12 IF Z="87.37"!(Z="87.36")
SET G=Z
End DoDot:1
+13 IF G]""
QUIT "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 ;I Z=76091!(Z=76090)!(Z=76092)!(Z="G0202")!(Z="G0204")!(Z="G0206")!(Z=77055)!(Z=77056)!(Z=77057)!(Z=77058)!(Z=77059) S G="V CPT: "_Z
+17 IF $$ICD^ATXCHK(Z,$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1)
SET G=Y
End DoDot:1
+18 IF G
QUIT "V CPT: "_Y
+19 QUIT ""
TEST ;
+1 SET X=$$MAMM(28797)
+2 QUIT
