BUD0RPC1.m

BUD0RPC1 ; 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("BUD0RPT1",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("BUD0RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN)) Q  ;patient already a hit on this line

 S ^XTMP("BUD0RPT1",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=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("BUD0RPT1",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("BUD0RPT1",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^BUD0RPC2(BUDV) I BUDVAL]"" S C=26 D PT

 S BUDVAL=$$L26A^BUD0RPC2(BUDV) I BUDVAL]"" S C="26.1" D PT

 S BUDVAL=$$L26B^BUD0RPC2(BUDV) I BUDVAL]"" S C="26.2" D PT

 S BUDVAL=$$L26C^BUD0RPC2(BUDV) I BUDVAL]"" S C="26.3" D PT

 S BUDVAL=$$L26D^BUD0RPC2(BUDV) I BUDVAL]"" S C="26.4" D PT

 S BUDVAL=$$L27^BUD0RPC2(BUDV) I BUDVAL]"" S C=27 D PT

 S BUDVAL=$$L28^BUD0RPC2(BUDV) I BUDVAL]"" S C=28 D PT

 S BUDVAL=$$L29^BUD0RPC2(BUDV) I BUDVAL]"" S C=29 D PT

 S BUDVAL=$$L30^BUD0RPC2(BUDV) I BUDVAL]"" S C=30 D PT

 S BUDVAL=$$L31^BUD0RPC2(BUDV) I BUDVAL]"" S C=31 D PT

 S BUDVAL=$$L32^BUD0RPC2(BUDV) I BUDVAL]"" S C=32 D PT

 S BUDVAL=$$L33^BUD0RPC2(BUDV) I BUDVAL]"" S C=33 D PT

 S BUDVAL=$$L34^BUD0RPC2(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) 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") 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 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 10 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(^BUDTCNTL("B","IMMUNIZATIONS LINE 24",0))

 .I $D(^BUDTCNTL(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 ""

BUD0RPC1  ; 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("BUD0RPT1",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("BUD0RPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN))

               QUIT 

 +2        SET ^XTMP("BUD0RPT1",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=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")