BUD8RP6C ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2008 3:10 PM 30 Dec 2008 7:19 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
GETIMMS(P,BDATE,EDATE,C,BUDX) ;EP
K BUDX
NEW X,Y,I,Z,V
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIMM(X,0)) ;happens
.S Y=$P(^AUPNVIMM(X,0),U)
.Q:'Y ;happens too
.S I=$P($G(^AUTTIMM(Y,0)),U,3) ;get HL7/CVX code
.F Z=1:1:$L(C,U) I I=$P(C,U,Z) S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".") I D]"",D'>EDATE,D'<BDATE S BUDX(D)="CVX: "_I_" on "_$$DATE^BUD8UTL1(D)
.Q
Q
;
IMM ;EP - called from xbdbque
;must have DOB between 1/1/06 and 12/31/06
S BUDDOB=$P(^DPT(DFN,0),U,3)
;Q:BUDDOB<3060101
;Q:BUDDOB>3061231
Q:BUDDOB<3010101
Q:BUDDOB>3011231
S BUD2ND=$E(BUDDOB,1,3)+2_$E(BUDDOB,4,7)
S BUD1ST=$E(BUDDOB,1,3)+1_$E(BUDDOB,4,7)
;
;S X=$$VBBD^BUD8RP6D(DFN,BUDDOB,$$FMADD^XLFDT(BUD2ND,-1))
Q:BUDMEDV<1
S BUDVBBD=$$VBBD^BUD8RP6D(DFN,BUDDOB,$$FMADD^XLFDT(BUD2ND,-1)) I 'BUDVBBD Q ;no visit before 2nd bd
S BUDSECTC("PTS")=$G(BUDSECTC("PTS"))+1
S BUD42D=$$FMADD^XLFDT(BUDDOB,42)
S (BUDNDTP,BUDNIPV,BUDNMMR,BUDNHEP,BUDNHIB,BUDNVAR,BUDNPNEU)=""
S BUDNDTP=$$DTAP^BUD8RP6X(DFN,BUD42D,BUD2ND)
S BUDNIPV=$$IPV(DFN,BUD42D,BUD2ND)
S BUDNMMR=$$MMR(DFN,BUDDOB,BUD2ND)
S BUDNHEP=$$HEP^BUD8RP6Y(DFN,BUDDOB,BUD2ND)
S BUDNHIB=$$HIB^BUD8RP6Y(DFN,BUD42D,BUD2ND)
S BUDNVAR=$$VAR^BUD8RP6Y(DFN,BUD1ST,BUD2ND)
S BUDNPNEU=$$PNEU^BUD8RP6Y(DFN,BUDDOB,BUD2ND)
I BUDNDTP]"",BUDNIPV]"",BUDNMMR]"",BUDNHEP]"",BUDNHIB]"",BUDNVAR]"",BUDNPNEU]"" S BUDSECTC("IMM")=$G(BUDSECTC("IMM"))+1 D Q
.I $G(BUDIMM1L) D
..S ^XTMP("BUD8RP6B",BUDJ,BUDH,"IMM1",$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDNDTP_U_BUDNIPV_U_BUDNMMR_U_BUDNHEP_U_BUDNHIB_U_BUDNVAR_U_BUDNPNEU_"|||"_BUDVBDD_U_BUDMEDVI
..Q
I $G(BUDIMM2L) D
.S V=$S(BUDNDTP]"":"",1:"4 dtp")_$S(BUDNIPV]"":"",1:";3 IPV")_$S(BUDNMMR]"":"",1:";1 MMR")_$S(BUDNHEP]"":"",1:";3 HEP")_$S(BUDNHIB]"":"",1:";3 HIB")_$S(BUDNVAR]"":"",1:";VARI")_$S(BUDNPNEU]"":"",1:";4 PNEUMO")
.S ^XTMP("BUD8RP6B",BUDJ,BUDH,"IMM2",$P(^DPT(DFN,0),U),BUDCOM,DFN)=V
Q
;
ANAREACT(I) ;EP
NEW X,Y,R
S X=0,Y=0 F S X=$O(^GMR(120.8,I,10,X)) Q:X'=+X D
.S R=$P($G(^GMR(120.8,I,10,X,0)),U)
.Q:R=""
.S R=$P($G(^GMRD(120.83,R,0)),U)
.I R'="ANAPHYLAXIS" Q
.S Y=1
.Q
Q Y
;
ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRAINDICATION
NEW X
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.;Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
Q G
;
ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRAINDICATION
NEW X
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.;Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
.I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Neomycin Allergy"
Q G
;
MMRCONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN/IMMUNE CONTRAINDICATION
NEW X
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.;Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
.I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Neomycin Allergy"
.I $P(^BICONT(R,0),U,1)="Immune Deficiency" S G=D_U_"Immune Deficiency"
.I $P(^BICONT(R,0),U,1)["Immune Deficient" S G=D_U_"Immune Deficient"
Q G
;
IPV(P,BDATE,EDATE) ;EP
;check for a contraindication from DOB to 2nd birthday
NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
IPVCONT ;check allergy tracking
S G=""
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(G) D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.Q:'$$ANAREACT(X) ;quit if anaphylactic is not a reaction/sign/symptom
.I N["STREPTOMYCIN"!(N["POLYMYXIN B")!(N["NEOMYCIN") S G="IPV Contraindiction: "_$$DATE^BUD8UTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
I G]"" Q G
;now check immunization package
F BUDZ=10,110,120,130 S X=$$ANNECONT(P,BUDZ,EDATE) Q:X]""
I X]"" Q "IPV Contraindication IM package: "_$$DATE^BUD8UTL1($P(X,U))_" "_$P(X,U,2)
;now check for evidence of disease
IPVEVID ;
K BUDG S %=P_"^LAST DX [BUD IPV EVID DISEASE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) Q "IPV Evidence: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U))
S X=$$PLTAX^BUD8DU(P,"BUD IPV EVID DISEASE") I X Q "IPV Evidence: Problem List "_$P(X,U,2)
;now get imms and see if there are 3
K BUDC,BUDG,BUDX
K BUDOPV,BUDAPOV
IPVIMM ;get all immunizations
S C="10^110^120^130"
K BUDX D GETIMMS(P,BDATE,EDATE,C,.BUDX)
;now get cpt codes
S X=0 F S X=$O(BUDX(X)) Q:X'=+X S BUDOPV(X)=BUDX(X),BUDAPOV(X)=BUDX(X)
;now get cpts
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) D
....I Y=90698!(Y=90713)!(Y=90723) S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD8UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD8UTL1((9999999-$P(ED,".")))
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Y=$P($$CPT^ICPTCOD(Y),U,2) D
....I Y=90698!(Y=90713)!(Y=90723) S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD8UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD8UTL1((9999999-$P(ED,".")))
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BUDOPV(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDOPV(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BUDOPV=0,X=0 F S X=$O(BUDOPV(X)) Q:X'=+X S BUDOPV=BUDOPV+1
I BUDOPV>2 S Y="IPV: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>2 Q Y
;now get povs
K BUDPOV M BUDPOV=BUDAPOV
K BUDG S %=P_"^ALL DX V06.3;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDOPV($P(BUDG(X),U))="POV: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1)),BUDAOPV($P(BUDG(X),U))="POV: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
K BUDG S %=P_"^ALL DX V04.0;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDOPV($P(BUDG(X),U))="POV: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1)),BUDAOPV($P(BUDG(X),U))="POV: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
K BUDG S %=P_"^ALL PROCEDURE 99.41;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDOPV($P(BUDG(X),U))="Procedure: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1)),BUDAPOV($P(BUDG(X),U))="Procedure: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BUDOPV(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDOPV(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BUDOPV=0,X=0 F S X=$O(BUDOPV(X)) Q:X'=+X S BUDOPV=BUDOPV+1
I BUDOPV>2 S Y="IPV: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>2 Q Y
Q ""
;
MMR(P,BDATE,EDATE) ;EP
;first check for contraindications
;dx first
MMRC ;
NEW BUDG,%,X,BUDZ,BUDC,BUDX,G,N
K BUDG S %=P_"^LAST DX [BGP MMR CONTRAINDICATIONS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) Q "MMR CONTRA DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U))
S X=$$PLTAX^BUD8DU(P,"BGP MMR CONTRAINDICATIONS") I X Q "MMR CONTRA DX: "_$P(X,U,2)_" on Problem List"
S G=""
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(G) D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.Q:'$$ANAREACT(X) ;quit if anaphylactic is not a reaction/sign/symptom
.I N["NEOMYCIN" S G="MMR Contraindiction: "_$$DATE^BUD8UTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
I G]"" Q G
F BUDZ=3,94,4,38,5,7,6 S X=$$MMRCONT(P,BUDZ,EDATE) Q:X]""
I X]"" Q "MMR Contraindication: "_$P(X,U,2)_" on "_$$DATE^BUD8UTL1($P(X,U,1))_" Immunization Package"
MMREVID ;
;any evidence of MMR?
;no codes for MMR, only individual
MMRI ;
K BUDC,BUDG,BUDX
K ^TMP($J,"CPT")
S (BUDMMR,BUDMUMPS,BUDRUB,BUDMEAS)="" ;set to null for all
;first gather up all cpt codes that relate in any way to dtap and store in ^TMP
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=+Y,$T(@Y)]"" S ^TMP($J,"CPT",9999999-$P(ED,"."),Y)=""
;get all immunizations
S C="3^94"
K BUDX D GETIMMS(P,BDATE,EDATE,C,.BUDX) ;before 2nd birthday
I $D(BUDX) S D=$O(BUDX(0)) Q "MMR "_BUDX(D) ;HAD 1 MMR
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90707!(Y=90710) S BUDMMR="CPT: "_Y_" on "_$$DATE^BUD8UTL1(D)
I BUDMMR]"" Q "MMR "_BUDMMR
;
K BUDG S %=P_"^ALL DX V06.4;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) Q "MMR DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U))
K BUDG S %=P_"^ALL PROCEDURE 99.48;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) Q "MMR PROCEDURE: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U))
;now check individuals
MR ;see if one M/R, Mumps or R/M
S BUDVALUE=""
S C=4
K BUDX D GETIMMS(P,BDATE,EDATE,C,.BUDX)
I $D(BUDX) S BUDMEAS=1,BUDRUB=1,BUDVALUE="MEASLES/RUBELLA " S D=$O(BUDX(0)) S BUDVALUE=BUDVALUE_BUDX(D)
I 'BUDMEAS!('BUDRUB) S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90708 S BUDMEAS=1,BUDRUB=1,BUDVALUE=BUDVALUE_" MEASLES/RUBELLA CPT: "_Y_" on "_$$DATE^BUD8UTL1(D)
RM ;
S C=38
D GETIMMS(P,BDATE,EDATE,C,.BUDX)
I $D(BUDX) S BUDRUB=1,BUDMUMPS=1 S D=$O(BUDX(0)) S BUDVALUE=BUDVALUE_" RUBELLA/MUMPS "_BUDX(D)
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90709 S BUDMUMPS=1,BUDRUB=1,BUDVALUE=BUDVALUE_" RUBELLA/MUMPS CPT "_Y_" on "_$$DATE^BUD8UTL1(D)
ME S C=5
K BUDX D GETIMMS(P,BDATE,EDATE,C,.BUDX)
I $D(BUDX) S BUDMEAS=1 S D=$O(BUDX(0)) S BUDVALUE=BUDVALUE_" MEASLES "_BUDX(D)
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90705 S BUDMEAS=1,BUDVALUE=BUDVALUE_" MEASLES CPT "_Y_" on "_$$DATE^BUD8UTL1(D)
K BUDG S %=P_"^ALL DX V04.2;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S BUDMEAS=1,BUDVALUE=BUDVALUE_" MEASLES DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
K BUDG S %=P_"^ALL PROCEDURE 99.45;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S BUDMEAS=1,BUDVALUE=BUDVALUE_" MEASLES PROCEDURE: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
I BUDMEAS="" K BUDG S %=P_"^LAST DX [BGP MEASLES EVIDENCE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(") I $D(BUDG(1)) S BUDMEAS=1,BUDVALUE=BUDVALUE_" MEASLES EVIDENCE DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
I BUDMEAS="" S X=$$PLTAX^BUD8DU(P,"BGP MEASLES EVIDENCE") I X S BUDMEAS=1,BUDVALUE=BUDVALUE_" MEASLES EVIDENCE PROB LIST: "_$P(X,U,2)
I BUDMEAS,BUDMUMPS,BUDRUB Q BUDVALUE
MU S C=7
D GETIMMS(P,BDATE,EDATE,C,.BUDX)
I $D(BUDX) S BUDMUMPS=1 S D=$O(BUDX(0)) S BUDVALUE=BUDVALUE_" MUMPS "_BUDX(D)
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90704 S BUDMU=1,BUDVALUE=BUDVALUE_" MUMPS CPT "_Y_" on "_$$DATE^BUD8UTL1(D)
K BUDG S %=P_"^ALL DX V04.6;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S BUDMEAS=1,BUDVALUE=BUDVALUE_" MUMPS DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
K BUDG S %=P_"^ALL PROCEDURE 99.46;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S BUDMEAS=1,BUDVALUE=BUDVALUE_" MUMPS PROCEDURE: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
I BUDMEAS="" K BUDG S %=P_"^LAST DX [BGP MUMPS EVIDENCE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(") I $D(BUDG(1)) S BUDMEAS=1,BUDVALUE=BUDVALUE_" MUMPS EVIDENCE DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
I BUDMEAS="" S X=$$PLTAX^BUD8DU(P,"BGP MUMPS EVIDENCE") I X S BUDMEAS=1,BUDVALUE=BUDVALUE_" MUMPS EVIDENCE PROB LIST: "_$P(X,U,2)
I BUDMEAS,BUDMUMPS,BUDRUB Q BUDVALUE
RUB S C=6
D GETIMMS(P,BDATE,EDATE,C,.BUDX)
I $D(BUDX) S BUDRUB=1,D=$O(BUDX(0)) S BUDVALUE=BUDVALUE_" RUBELLA "_BUDX(D)
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90706 S BUDRUB=1,BUDVALUE=BUDVALUE_" RUBELLA CPT "_Y_" on "_$$DATE^BUD8UTL1(D)
K BUDG S %=P_"^ALL DX V04.3;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S BUDMEAS=1,BUDVALUE=BUDVALUE_" RUBELLA DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
K BUDG S %=P_"^ALL PROCEDURE 99.47;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S BUDMEAS=1,BUDVALUE=BUDVALUE_" RUBELLA PROCEDURE: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
I BUDMEAS="" K BUDG S %=P_"^LAST DX [BGP RUBELLA EVIDENCE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(") I $D(BUDG(1)) S BUDMEAS=1,BUDVALUE=BUDVALUE_" RUBELLA EVIDENCE DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($P(BUDG(1),U,1))
I BUDMEAS="" S X=$$PLTAX^BUD8DU(P,"BGP RUBELLA EVIDENCE") I X S BUDMEAS=1,BUDVALUE=BUDVALUE_" RUBELLA EVIDENCE PROB LIST: "_$P(X,U,2)
I BUDMEAS,BUDMUMPS,BUDRUB Q BUDVALUE
Q ""
;
90707 ;;
90710 ;;
90708 ;;
90709 ;;
90705 ;;
90704 ;;
90706 ;;
BUD8RP6C ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2008 3:10 PM 30 Dec 2008 7:19 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
GETIMMS(P,BDATE,EDATE,C,BUDX) ;EP
+1 KILL BUDX
+2 NEW X,Y,I,Z,V
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;happens
IF '$DATA(^AUPNVIMM(X,0))
QUIT
+5 SET Y=$PIECE(^AUPNVIMM(X,0),U)
+6 ;happens too
IF 'Y
QUIT
+7 ;get HL7/CVX code
SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+8 FOR Z=1:1:$LENGTH(C,U)
IF I=$PIECE(C,U,Z)
SET V=$PIECE(^AUPNVIMM(X,0),U,3)
IF V
SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
IF D]""
IF D'>EDATE
IF D'<BDATE
SET BUDX(D)="CVX: "_I_" on "_$$DATE^BUD8UTL1(D)
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
IMM ;EP - called from xbdbque
+1 ;must have DOB between 1/1/06 and 12/31/06
+2 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+3 ;Q:BUDDOB<3060101
+4 ;Q:BUDDOB>3061231
+5 IF BUDDOB<3010101
QUIT
+6 IF BUDDOB>3011231
QUIT
+7 SET BUD2ND=$EXTRACT(BUDDOB,1,3)+2_$EXTRACT(BUDDOB,4,7)
+8 SET BUD1ST=$EXTRACT(BUDDOB,1,3)+1_$EXTRACT(BUDDOB,4,7)
+9 ;
+10 ;S X=$$VBBD^BUD8RP6D(DFN,BUDDOB,$$FMADD^XLFDT(BUD2ND,-1))
+11 IF BUDMEDV<1
QUIT
+12 ;no visit before 2nd bd
SET BUDVBBD=$$VBBD^BUD8RP6D(DFN,BUDDOB,$$FMADD^XLFDT(BUD2ND,-1))
IF 'BUDVBBD
QUIT
+13 SET BUDSECTC("PTS")=$GET(BUDSECTC("PTS"))+1
+14 SET BUD42D=$$FMADD^XLFDT(BUDDOB,42)
+15 SET (BUDNDTP,BUDNIPV,BUDNMMR,BUDNHEP,BUDNHIB,BUDNVAR,BUDNPNEU)=""
+16 SET BUDNDTP=$$DTAP^BUD8RP6X(DFN,BUD42D,BUD2ND)
+17 SET BUDNIPV=$$IPV(DFN,BUD42D,BUD2ND)
+18 SET BUDNMMR=$$MMR(DFN,BUDDOB,BUD2ND)
+19 SET BUDNHEP=$$HEP^BUD8RP6Y(DFN,BUDDOB,BUD2ND)
+20 SET BUDNHIB=$$HIB^BUD8RP6Y(DFN,BUD42D,BUD2ND)
+21 SET BUDNVAR=$$VAR^BUD8RP6Y(DFN,BUD1ST,BUD2ND)
+22 SET BUDNPNEU=$$PNEU^BUD8RP6Y(DFN,BUDDOB,BUD2ND)
+23 IF BUDNDTP]""
IF BUDNIPV]""
IF BUDNMMR]""
IF BUDNHEP]""
IF BUDNHIB]""
IF BUDNVAR]""
IF BUDNPNEU]""
SET BUDSECTC("IMM")=$GET(BUDSECTC("IMM"))+1
Begin DoDot:1
+24 IF $GET(BUDIMM1L)
Begin DoDot:2
+25 SET ^XTMP("BUD8RP6B",BUDJ,BUDH,"IMM1",$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDNDTP_U_BUDNIPV_U_BUDNMMR_U_BUDNHEP_U_BUDNHIB_U_BUDNVAR_U_BUDNPNEU_"|||"_BUDVBDD_U_BUDMEDVI
+26 QUIT
End DoDot:2
End DoDot:1
QUIT
+27 IF $GET(BUDIMM2L)
Begin DoDot:1
+28 SET V=$SELECT(BUDNDTP]"":"",1:"4 dtp")_$SELECT(BUDNIPV]"":"",1:";3 IPV")_$SELECT(BUDNMMR]"":"",1:";1 MMR")_$SELECT(BUDNHEP]"":"",1:";3 HEP")_$SELECT(BUDNHIB]"":"",1:";3 HIB")_$SELECT(BUDNVAR]"":"",1:";VARI")_$SELECT(BUDNPNEU]"":"",1:";4
PNEUMO")
+29 SET ^XTMP("BUD8RP6B",BUDJ,BUDH,"IMM2",$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=V
End DoDot:1
+30 QUIT
+31 ;
ANAREACT(I) ;EP
+1 NEW X,Y,R
+2 SET X=0
SET Y=0
FOR
SET X=$ORDER(^GMR(120.8,I,10,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET R=$PIECE($GET(^GMR(120.8,I,10,X,0)),U)
+4 IF R=""
QUIT
+5 SET R=$PIECE($GET(^GMRD(120.83,R,0)),U)
+6 IF R'="ANAPHYLAXIS"
QUIT
+7 SET Y=1
+8 QUIT
End DoDot:1
+9 QUIT Y
+10 ;
ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRAINDICATION
+1 NEW X
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Anaphylaxis"
End DoDot:1
+11 QUIT G
+12 ;
ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRAINDICATION
+1 NEW X
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Anaphylaxis"
+11 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Neomycin Allergy"
End DoDot:1
+12 QUIT G
+13 ;
MMRCONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN/IMMUNE CONTRAINDICATION
+1 NEW X
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Anaphylaxis"
+11 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Neomycin Allergy"
+12 IF $PIECE(^BICONT(R,0),U,1)="Immune Deficiency"
SET G=D_U_"Immune Deficiency"
+13 IF $PIECE(^BICONT(R,0),U,1)["Immune Deficient"
SET G=D_U_"Immune Deficient"
End DoDot:1
+14 QUIT G
+15 ;
IPV(P,BDATE,EDATE) ;EP
+1 ;check for a contraindication from DOB to 2nd birthday
+2 NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
IPVCONT ;check allergy tracking
+1 SET G=""
+2 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 ;entered after 2ND birthday
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+4 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+5 ;quit if anaphylactic is not a reaction/sign/symptom
IF '$$ANAREACT(X)
QUIT
+6 IF N["STREPTOMYCIN"!(N["POLYMYXIN B")!(N["NEOMYCIN")
SET G="IPV Contraindiction: "_$$DATE^BUD8UTL1($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+7 IF G]""
QUIT G
+8 ;now check immunization package
+9 FOR BUDZ=10,110,120,130
SET X=$$ANNECONT(P,BUDZ,EDATE)
IF X]""
QUIT
+10 IF X]""
QUIT "IPV Contraindication IM package: "_$$DATE^BUD8UTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+11 ;now check for evidence of disease
IPVEVID ;
+1 KILL BUDG
SET %=P_"^LAST DX [BUD IPV EVID DISEASE;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+2 IF $DATA(BUDG(1))
QUIT "IPV Evidence: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U))
+3 SET X=$$PLTAX^BUD8DU(P,"BUD IPV EVID DISEASE")
IF X
QUIT "IPV Evidence: Problem List "_$PIECE(X,U,2)
+4 ;now get imms and see if there are 3
+5 KILL BUDC,BUDG,BUDX
+6 KILL BUDOPV,BUDAPOV
IPVIMM ;get all immunizations
+1 SET C="10^110^120^130"
+2 KILL BUDX
DO GETIMMS(P,BDATE,EDATE,C,.BUDX)
+3 ;now get cpt codes
+4 SET X=0
FOR
SET X=$ORDER(BUDX(X))
IF X'=+X
QUIT
SET BUDOPV(X)=BUDX(X)
SET BUDAPOV(X)=BUDX(X)
+5 ;now get cpts
+6 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+7 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+8 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
Begin DoDot:4
+12 IF Y=90698!(Y=90713)!(Y=90723)
SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD8UTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD8UTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+14 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
Begin DoDot:4
+15 IF Y=90698!(Y=90713)!(Y=90723)
SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD8UTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD8UTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+17 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+18 IF C=1
SET Y=X
QUIT
+19 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDOPV(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 ;now count them and see if there are 4 of them
+22 SET BUDOPV=0
SET X=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET BUDOPV=BUDOPV+1
+23 IF BUDOPV>2
SET Y="IPV: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+24 IF BUDOPV>2
QUIT Y
+25 ;now get povs
+26 KILL BUDPOV
MERGE BUDPOV=BUDAPOV
+27 KILL BUDG
SET %=P_"^ALL DX V06.3;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+28 IF $DATA(BUDG(1))
SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDOPV($PIECE(BUDG(X),U))="POV: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
SET BUDAOPV($PIECE(BUDG(X),U))="POV: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+29 KILL BUDG
SET %=P_"^ALL DX V04.0;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+30 IF $DATA(BUDG(1))
SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDOPV($PIECE(BUDG(X),U))="POV: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
SET BUDAOPV($PIECE(BUDG(X),U))="POV: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+31 KILL BUDG
SET %=P_"^ALL PROCEDURE 99.41;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+32 IF $DATA(BUDG(1))
SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDOPV($PIECE(BUDG(X),U))="Procedure: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
SET BUDAPOV($PIECE(BUDG(X),U))="Procedure: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+33 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+34 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+35 IF C=1
SET Y=X
QUIT
+36 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDOPV(X)
QUIT
+37 SET Y=X
End DoDot:1
+38 ;now count them and see if there are 4 of them
+39 SET BUDOPV=0
SET X=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET BUDOPV=BUDOPV+1
+40 IF BUDOPV>2
SET Y="IPV: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+41 IF BUDOPV>2
QUIT Y
+42 QUIT ""
+43 ;
MMR(P,BDATE,EDATE) ;EP
+1 ;first check for contraindications
+2 ;dx first
MMRC ;
+1 NEW BUDG,%,X,BUDZ,BUDC,BUDX,G,N
+2 KILL BUDG
SET %=P_"^LAST DX [BGP MMR CONTRAINDICATIONS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 IF $DATA(BUDG(1))
QUIT "MMR CONTRA DX: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U))
+4 SET X=$$PLTAX^BUD8DU(P,"BGP MMR CONTRAINDICATIONS")
IF X
QUIT "MMR CONTRA DX: "_$PIECE(X,U,2)_" on Problem List"
+5 SET G=""
+6 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+7 ;entered after 2ND birthday
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+8 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+9 ;quit if anaphylactic is not a reaction/sign/symptom
IF '$$ANAREACT(X)
QUIT
+10 IF N["NEOMYCIN"
SET G="MMR Contraindiction: "_$$DATE^BUD8UTL1($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+11 IF G]""
QUIT G
+12 FOR BUDZ=3,94,4,38,5,7,6
SET X=$$MMRCONT(P,BUDZ,EDATE)
IF X]""
QUIT
+13 IF X]""
QUIT "MMR Contraindication: "_$PIECE(X,U,2)_" on "_$$DATE^BUD8UTL1($PIECE(X,U,1))_" Immunization Package"
MMREVID ;
+1 ;any evidence of MMR?
+2 ;no codes for MMR, only individual
MMRI ;
+1 KILL BUDC,BUDG,BUDX
+2 KILL ^TMP($JOB,"CPT")
+3 ;set to null for all
SET (BUDMMR,BUDMUMPS,BUDRUB,BUDMEAS)=""
+4 ;first gather up all cpt codes that relate in any way to dtap and store in ^TMP
+5 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+6 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+7 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=+Y
IF $TEXT(@Y)]""
SET ^TMP($JOB,"CPT",9999999-$PIECE(ED,"."),Y)=""
End DoDot:3
End DoDot:2
End DoDot:1
+12 ;get all immunizations
+13 SET C="3^94"
+14 ;before 2nd birthday
KILL BUDX
DO GETIMMS(P,BDATE,EDATE,C,.BUDX)
+15 ;HAD 1 MMR
IF $DATA(BUDX)
SET D=$ORDER(BUDX(0))
QUIT "MMR "_BUDX(D)
+16 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+17 IF Y=90707!(Y=90710)
SET BUDMMR="CPT: "_Y_" on "_$$DATE^BUD8UTL1(D)
End DoDot:1
+18 IF BUDMMR]""
QUIT "MMR "_BUDMMR
+19 ;
+20 KILL BUDG
SET %=P_"^ALL DX V06.4;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+21 IF $DATA(BUDG(1))
QUIT "MMR DX: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U))
+22 KILL BUDG
SET %=P_"^ALL PROCEDURE 99.48;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+23 IF $DATA(BUDG(1))
QUIT "MMR PROCEDURE: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U))
+24 ;now check individuals
MR ;see if one M/R, Mumps or R/M
+1 SET BUDVALUE=""
+2 SET C=4
+3 KILL BUDX
DO GETIMMS(P,BDATE,EDATE,C,.BUDX)
+4 IF $DATA(BUDX)
SET BUDMEAS=1
SET BUDRUB=1
SET BUDVALUE="MEASLES/RUBELLA "
SET D=$ORDER(BUDX(0))
SET BUDVALUE=BUDVALUE_BUDX(D)
+5 IF 'BUDMEAS!('BUDRUB)
SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+6 IF Y=90708
SET BUDMEAS=1
SET BUDRUB=1
SET BUDVALUE=BUDVALUE_" MEASLES/RUBELLA CPT: "_Y_" on "_$$DATE^BUD8UTL1(D)
End DoDot:1
RM ;
+1 SET C=38
+2 DO GETIMMS(P,BDATE,EDATE,C,.BUDX)
+3 IF $DATA(BUDX)
SET BUDRUB=1
SET BUDMUMPS=1
SET D=$ORDER(BUDX(0))
SET BUDVALUE=BUDVALUE_" RUBELLA/MUMPS "_BUDX(D)
+4 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+5 IF Y=90709
SET BUDMUMPS=1
SET BUDRUB=1
SET BUDVALUE=BUDVALUE_" RUBELLA/MUMPS CPT "_Y_" on "_$$DATE^BUD8UTL1(D)
End DoDot:1
ME SET C=5
+1 KILL BUDX
DO GETIMMS(P,BDATE,EDATE,C,.BUDX)
+2 IF $DATA(BUDX)
SET BUDMEAS=1
SET D=$ORDER(BUDX(0))
SET BUDVALUE=BUDVALUE_" MEASLES "_BUDX(D)
+3 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+4 IF Y=90705
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" MEASLES CPT "_Y_" on "_$$DATE^BUD8UTL1(D)
End DoDot:1
+5 KILL BUDG
SET %=P_"^ALL DX V04.2;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+6 IF $DATA(BUDG(1))
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" MEASLES DX: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+7 KILL BUDG
SET %=P_"^ALL PROCEDURE 99.45;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+8 IF $DATA(BUDG(1))
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" MEASLES PROCEDURE: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+9 IF BUDMEAS=""
KILL BUDG
SET %=P_"^LAST DX [BGP MEASLES EVIDENCE;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
IF $DATA(BUDG(1))
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" MEASLES EVIDENCE DX: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+10 IF BUDMEAS=""
SET X=$$PLTAX^BUD8DU(P,"BGP MEASLES EVIDENCE")
IF X
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" MEASLES EVIDENCE PROB LIST: "_$PIECE(X,U,2)
+11 IF BUDMEAS
IF BUDMUMPS
IF BUDRUB
QUIT BUDVALUE
MU SET C=7
+1 DO GETIMMS(P,BDATE,EDATE,C,.BUDX)
+2 IF $DATA(BUDX)
SET BUDMUMPS=1
SET D=$ORDER(BUDX(0))
SET BUDVALUE=BUDVALUE_" MUMPS "_BUDX(D)
+3 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+4 IF Y=90704
SET BUDMU=1
SET BUDVALUE=BUDVALUE_" MUMPS CPT "_Y_" on "_$$DATE^BUD8UTL1(D)
End DoDot:1
+5 KILL BUDG
SET %=P_"^ALL DX V04.6;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+6 IF $DATA(BUDG(1))
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" MUMPS DX: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+7 KILL BUDG
SET %=P_"^ALL PROCEDURE 99.46;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+8 IF $DATA(BUDG(1))
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" MUMPS PROCEDURE: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+9 IF BUDMEAS=""
KILL BUDG
SET %=P_"^LAST DX [BGP MUMPS EVIDENCE;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
IF $DATA(BUDG(1))
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" MUMPS EVIDENCE DX: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+10 IF BUDMEAS=""
SET X=$$PLTAX^BUD8DU(P,"BGP MUMPS EVIDENCE")
IF X
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" MUMPS EVIDENCE PROB LIST: "_$PIECE(X,U,2)
+11 IF BUDMEAS
IF BUDMUMPS
IF BUDRUB
QUIT BUDVALUE
RUB SET C=6
+1 DO GETIMMS(P,BDATE,EDATE,C,.BUDX)
+2 IF $DATA(BUDX)
SET BUDRUB=1
SET D=$ORDER(BUDX(0))
SET BUDVALUE=BUDVALUE_" RUBELLA "_BUDX(D)
+3 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+4 IF Y=90706
SET BUDRUB=1
SET BUDVALUE=BUDVALUE_" RUBELLA CPT "_Y_" on "_$$DATE^BUD8UTL1(D)
End DoDot:1
+5 KILL BUDG
SET %=P_"^ALL DX V04.3;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+6 IF $DATA(BUDG(1))
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" RUBELLA DX: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+7 KILL BUDG
SET %=P_"^ALL PROCEDURE 99.47;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+8 IF $DATA(BUDG(1))
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" RUBELLA PROCEDURE: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+9 IF BUDMEAS=""
KILL BUDG
SET %=P_"^LAST DX [BGP RUBELLA EVIDENCE;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
IF $DATA(BUDG(1))
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" RUBELLA EVIDENCE DX: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUD8UTL1($PIECE(BUDG(1),U,1))
+10 IF BUDMEAS=""
SET X=$$PLTAX^BUD8DU(P,"BGP RUBELLA EVIDENCE")
IF X
SET BUDMEAS=1
SET BUDVALUE=BUDVALUE_" RUBELLA EVIDENCE PROB LIST: "_$PIECE(X,U,2)
+11 IF BUDMEAS
IF BUDMUMPS
IF BUDRUB
QUIT BUDVALUE
+12 QUIT ""
+13 ;
90707 ;;
90710 ;;
90708 ;;
90709 ;;
90705 ;;
90704 ;;
90706 ;;
