BUDARP6Y ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 4:03 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
;
HEP(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
HEPCONT ;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^BUDARP6C(X) ;quit if anaphylactic is not a reaction/sign/symptom
.I N["BAKER'S YEAST"!(N["BAKERS YEAST")!(N["YEAST") S G="1^HEP B Contraindiction: "_$$DATE^BUDAUTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
I G]"" Q G
;now check immunization package
F BUDZ=8,42,43,44,45,51,102,104,110,132 S X=$$ANCONT^BUDARP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^HEP B Contraindication IM package: "_$$DATE^BUDAUTL1($P(X,U))_" "_$P(X,U,2)
;now check for evidence of disease
HEPEVID ;
K BUDG S %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) Q "1^HEP B Evidence: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUDAUTL1($P(BUDG(1),U))
S X=$$PLTAX^BUDADU(P,"BGP HEP EVIDENCE") I X Q "1^HEP B Evidence: Problem List "_$P(X,U,2)
;now get imms and see if there are 3
K BUDC,BUDG,BUDX
K BUDOPV,BUDAPOV
HEPIMM ;get all immunizations
S C="8^42^43^44^45^51^102^104^110^132"
K BUDX D GETIMMS^BUDARP6C(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=90723!(Y=90740)!(Y=90744)!(Y=90747)!(Y=90748) S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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=90723!(Y=90740)!(Y=90744)!(Y=90747)!(Y=90748) S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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="1^HEP B: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>2 Q Y
Q "0^"_(3-BUDOPV)_" HEP B"
;
HIB(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
;now check for evidence of disease
F BUDZ=17,22,46,47,48,49,50,51,102,120,132,146 S X=$$ANCONT^BUDARP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^HIB Contraindication IM package: "_$$DATE^BUDAUTL1($P(X,U))_" "_$P(X,U,2)
HIBEVID ;
K BUDG S %=P_"^LAST DX [BUD HIB EVIDENCE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) Q "1^HIB Evidence: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUDAUTL1($P(BUDG(1),U))
S X=$$PLTAX^BUDADU(P,"BUD HIB EVIDENCE") I X Q "1^HIB Evidence: Problem List "_$P(X,U,2)
;now get imms and see if there are 3
K BUDC,BUDG,BUDX
K BUDOPV,BUDAPOV
HIBIMM ;get all immunizations
S C="17^22^46^47^48^49^50^51^102^120^132^146"
K BUDX D GETIMMS^BUDARP6C(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) I Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748) D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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) I Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748) D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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>1 S Y="1^HIB: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>1 Q Y
Q "0^"_(3-BUDOPV)_" HIB "_$S('BUDOPV:"(3 Recommended)",1:"(2 Recommended)")
;
VAR(P,BDATE,EDATE) ;EP
;first check for contraindications
VARC ;
NEW BUDG,%,X,BUDZ,BUDC,BUDX,G,N
K BUDG S %=P_"^LAST DX [BUD MMR CONTRAINDICATIONS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) Q "1^Varicella CONTRA DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUDAUTL1($P(BUDG(1),U))
S X=$$PLTAX^BUDADU(P,"BUD MMR CONTRAINDICATIONS") I X Q "1^VAR 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^BUDARP6C(X) ;quit if anaphylactic is not a reaction/sign/symptom
.I N["NEOMYCIN" S G="1^VAR Contraindiction: "_$$DATE^BUDAUTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
I G]"" Q G
F BUDZ=21,94 S X=$$MMRCONT^BUDARP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^Varicella Contraindication: "_$P(X,U,2)_" on "_$$DATE^BUDAUTL1($P(X,U,1))_" Immunization Package"
VAREVID ;
;any evidence of VAR?
K BUDG S %=P_"^LAST DX [BGP VARICELLA EVIDENCE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) Q "1^Varicella Evidence: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUDAUTL1($P(BUDG(1),U))
S X=$$PLTAX^BUDADU(P,"BGP VARICELLA EVIDENCE") I X Q "1^Varicella Evidence: Problem List "_$P(X,U,2)
VARI ;
K BUDC,BUDG,BUDX
S BUDVAR="" ;set to null for all
;first gather up all cpt codes that relate in any way to dtap and store in ^TMP
;get all immunizations
S C="21^94"
K BUDX D GETIMMS^BUDARP6C(P,BDATE,EDATE,C,.BUDX) ;before 2nd birthday
I $D(BUDX) S D=$O(BUDX(0)) Q "1^Varicella "_BUDX(D) ;HAD 1 VAR
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="90710"!(Y="90716") S BUDVAR="Varicella CPT: "_Y_" on "_$$DATE^BUDAUTL1($P($P(^AUPNVSIT(V,0),U),"."))
I BUDVAR]"" Q "1^"_BUDVAR
;
Q "0^1 VAR"
;
PNEU(P,BDATE,EDATE) ;EP
NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
;now get imms and see if there are 4
K BUDC,BUDG,BUDX
F BUDZ=33,100,109,133 S X=$$ANCONT^BUDARP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^Pneumovax Contraindication IM package: "_$$DATE^BUDAUTL1($P(X,U))_" "_$P(X,U,2)
K BUDOPV,BUDAPOV
PNEUIMM ;get all immunizations
S C="33^100^109^133"
K BUDX D GETIMMS^BUDARP6C(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) I Y=90669!(Y=90670) D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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) I Y=90669!(Y=90670) D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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>3 S Y="1^Pneumovax: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>3 Q Y
NEW X
S X=4-BUDOPV
Q "0^"_X_" PNEUMO"
;
HEPA(P,BDATE,EDATE) ;EP
NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
;now get imms and see if there are 4
K BUDC,BUDG,BUDX
F BUDZ=31,83,84,85 S X=$$ANCONT^BUDARP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^HEP A Contraindication IM package: "_$$DATE^BUDAUTL1($P(X,U))_" "_$P(X,U,2)
HEPAEVID ;
;any evidence of HEPA?
K BUDG S %=P_"^LAST DX [BGP HEPATITIS A EVIDENCE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) Q "1^HEP A Evidence: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUDAUTL1($P(BUDG(1),U))
S X=$$PLTAX^BUDADU(P,"BGP HEPATITIS A EVIDENCE") I X Q "1^HEP A Evidence: Problem List "_$P(X,U,2)
K BUDOPV,BUDAPOV
HEPAIMM ;get all immunizations
S C="31^83^84^85"
K BUDX D GETIMMS^BUDARP6C(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) I Y=90633!(Y=90634)!(Y=90730) D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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) I Y=90633!(Y=90634)!(Y=90730) D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,".")))
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>1 S Y="1^HEP A: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>1 Q Y
NEW X
S X=2-BUDOPV
Q "0^"_X_" HEP A"
;
FLU(P,BDATE,EDATE) ;EP
NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
;now get imms and see if there are 4
K BUDC,BUDG,BUDX
F BUDZ=15,16,88,111,135,140,141,144 S X=$$ROTACONT^BUDARP6W(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^Influenza Contraindication IM package: "_$$DATE^BUDAUTL1($P(X,U))_" "_$P(X,U,2)
F BUDZ=15,16,88,111,135,140,141,144 S X=$$EGGCONT^BUDARP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^Influenza Contraindication IM package: "_$$DATE^BUDAUTL1($P(X,U))_" "_$P(X,U,2)
S X=$$LASTDX^BUDAUTL1(P,"BUD ROTA CONTRA DXS",$$DOB^AUPNPAT(P),EDATE)
I X]"" Q "1^Influenza Contraindication: "_$P(X,U,2)_" on "_$$DATE^BUDAUTL1($P(X,U,3))
S X=$$PLTAX^BUDADU(P,"BUD ROTA CONTRA DXS") I X Q "1^Influenza Contraindication: "_$P(X,U,2)_" on Problem List"
K BUDOPV,BUDAPOV
FLUIMM ;get all immunizations
S C="15^16^88^111^135^140^141^144"
K BUDX D GETIMMS^BUDARP6C(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) I Y=90654!(Y=90655)!(Y=90657)!(Y=90660)!(Y=90661)!(Y=90662) D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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) I Y=90654!(Y=90655)!(Y=90657)!(Y=90660)!(Y=90661)!(Y=90662) D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,".")))
..S X=0 F S X=$O(^AUPNVPRC("AD",V,X)) Q:X'=+X D
...S Y=$$VAL^XBDIQ1(9000010.08,X,.01) I Y=99.52 D
....S BUDOPV(9999999-$P(ED,"."))="PROCEDURE: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="PROCEDURE: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,".")))
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>1 S Y="1^Influenza: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>1 Q Y
NEW X
S X=2-BUDOPV
Q "0^"_X_" Influenza"
;
BUDARP6Y ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 4:03 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
+4 ;
HEP(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
HEPCONT ;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 ;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
+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^BUDARP6C(X)
QUIT
+6 IF N["BAKER'S YEAST"!(N["BAKERS YEAST")!(N["YEAST")
SET G="1^HEP B Contraindiction: "_$$DATE^BUDAUTL1($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=8,42,43,44,45,51,102,104,110,132
SET X=$$ANCONT^BUDARP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+10 IF X]""
QUIT "1^HEP B Contraindication IM package: "_$$DATE^BUDAUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+11 ;now check for evidence of disease
HEPEVID ;
+1 KILL BUDG
SET %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+2 IF $DATA(BUDG(1))
QUIT "1^HEP B Evidence: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUDAUTL1($PIECE(BUDG(1),U))
+3 SET X=$$PLTAX^BUDADU(P,"BGP HEP EVIDENCE")
IF X
QUIT "1^HEP B 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
HEPIMM ;get all immunizations
+1 SET C="8^42^43^44^45^51^102^104^110^132"
+2 KILL BUDX
DO GETIMMS^BUDARP6C(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=90723!(Y=90740)!(Y=90744)!(Y=90747)!(Y=90748)
SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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=90723!(Y=90740)!(Y=90744)!(Y=90747)!(Y=90748)
SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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="1^HEP B: 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 QUIT "0^"_(3-BUDOPV)_" HEP B"
+26 ;
HIB(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
+3 ;now check for evidence of disease
+4 FOR BUDZ=17,22,46,47,48,49,50,51,102,120,132,146
SET X=$$ANCONT^BUDARP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+5 IF X]""
QUIT "1^HIB Contraindication IM package: "_$$DATE^BUDAUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
HIBEVID ;
+1 KILL BUDG
SET %=P_"^LAST DX [BUD HIB EVIDENCE;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+2 IF $DATA(BUDG(1))
QUIT "1^HIB Evidence: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUDAUTL1($PIECE(BUDG(1),U))
+3 SET X=$$PLTAX^BUDADU(P,"BUD HIB EVIDENCE")
IF X
QUIT "1^HIB 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
HIBIMM ;get all immunizations
+1 SET C="17^22^46^47^48^49^50^51^102^120^132^146"
+2 KILL BUDX
DO GETIMMS^BUDARP6C(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)
IF Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)
Begin DoDot:4
+12 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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)
IF Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)
Begin DoDot:4
+15 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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>1
SET Y="1^HIB: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+24 IF BUDOPV>1
QUIT Y
+25 QUIT "0^"_(3-BUDOPV)_" HIB "_$SELECT('BUDOPV:"(3 Recommended)",1:"(2 Recommended)")
+26 ;
VAR(P,BDATE,EDATE) ;EP
+1 ;first check for contraindications
VARC ;
+1 NEW BUDG,%,X,BUDZ,BUDC,BUDX,G,N
+2 KILL BUDG
SET %=P_"^LAST DX [BUD MMR CONTRAINDICATIONS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 IF $DATA(BUDG(1))
QUIT "1^Varicella CONTRA DX: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUDAUTL1($PIECE(BUDG(1),U))
+4 SET X=$$PLTAX^BUDADU(P,"BUD MMR CONTRAINDICATIONS")
IF X
QUIT "1^VAR 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 ;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
+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^BUDARP6C(X)
QUIT
+10 IF N["NEOMYCIN"
SET G="1^VAR Contraindiction: "_$$DATE^BUDAUTL1($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+11 IF G]""
QUIT G
+12 FOR BUDZ=21,94
SET X=$$MMRCONT^BUDARP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+13 IF X]""
QUIT "1^Varicella Contraindication: "_$PIECE(X,U,2)_" on "_$$DATE^BUDAUTL1($PIECE(X,U,1))_" Immunization Package"
VAREVID ;
+1 ;any evidence of VAR?
+2 KILL BUDG
SET %=P_"^LAST DX [BGP VARICELLA EVIDENCE;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 IF $DATA(BUDG(1))
QUIT "1^Varicella Evidence: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUDAUTL1($PIECE(BUDG(1),U))
+4 SET X=$$PLTAX^BUDADU(P,"BGP VARICELLA EVIDENCE")
IF X
QUIT "1^Varicella Evidence: Problem List "_$PIECE(X,U,2)
VARI ;
+1 KILL BUDC,BUDG,BUDX
+2 ;set to null for all
SET BUDVAR=""
+3 ;first gather up all cpt codes that relate in any way to dtap and store in ^TMP
+4 ;get all immunizations
+5 SET C="21^94"
+6 ;before 2nd birthday
KILL BUDX
DO GETIMMS^BUDARP6C(P,BDATE,EDATE,C,.BUDX)
+7 ;HAD 1 VAR
IF $DATA(BUDX)
SET D=$ORDER(BUDX(0))
QUIT "1^Varicella "_BUDX(D)
+8 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+14 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y="90710"!(Y="90716")
SET BUDVAR="Varicella CPT: "_Y_" on "_$$DATE^BUDAUTL1($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF BUDVAR]""
QUIT "1^"_BUDVAR
+16 ;
+17 QUIT "0^1 VAR"
+18 ;
PNEU(P,BDATE,EDATE) ;EP
+1 NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
+2 ;now get imms and see if there are 4
+3 KILL BUDC,BUDG,BUDX
+4 FOR BUDZ=33,100,109,133
SET X=$$ANCONT^BUDARP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+5 IF X]""
QUIT "1^Pneumovax Contraindication IM package: "_$$DATE^BUDAUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+6 KILL BUDOPV,BUDAPOV
PNEUIMM ;get all immunizations
+1 SET C="33^100^109^133"
+2 KILL BUDX
DO GETIMMS^BUDARP6C(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)
IF Y=90669!(Y=90670)
Begin DoDot:4
+12 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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)
IF Y=90669!(Y=90670)
Begin DoDot:4
+15 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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>3
SET Y="1^Pneumovax: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+24 IF BUDOPV>3
QUIT Y
+25 NEW X
+26 SET X=4-BUDOPV
+27 QUIT "0^"_X_" PNEUMO"
+28 ;
HEPA(P,BDATE,EDATE) ;EP
+1 NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
+2 ;now get imms and see if there are 4
+3 KILL BUDC,BUDG,BUDX
+4 FOR BUDZ=31,83,84,85
SET X=$$ANCONT^BUDARP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+5 IF X]""
QUIT "1^HEP A Contraindication IM package: "_$$DATE^BUDAUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
HEPAEVID ;
+1 ;any evidence of HEPA?
+2 KILL BUDG
SET %=P_"^LAST DX [BGP HEPATITIS A EVIDENCE;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 IF $DATA(BUDG(1))
QUIT "1^HEP A Evidence: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUDAUTL1($PIECE(BUDG(1),U))
+4 SET X=$$PLTAX^BUDADU(P,"BGP HEPATITIS A EVIDENCE")
IF X
QUIT "1^HEP A Evidence: Problem List "_$PIECE(X,U,2)
+5 KILL BUDOPV,BUDAPOV
HEPAIMM ;get all immunizations
+1 SET C="31^83^84^85"
+2 KILL BUDX
DO GETIMMS^BUDARP6C(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)
IF Y=90633!(Y=90634)!(Y=90730)
Begin DoDot:4
+12 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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)
IF Y=90633!(Y=90634)!(Y=90730)
Begin DoDot:4
+15 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+17 IF C=1
SET Y=X
QUIT
+18 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDOPV(X)
QUIT
+19 SET Y=X
End DoDot:1
+20 ;now count them and see if there are 4 of them
+21 SET BUDOPV=0
SET X=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET BUDOPV=BUDOPV+1
+22 IF BUDOPV>1
SET Y="1^HEP A: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+23 IF BUDOPV>1
QUIT Y
+24 NEW X
+25 SET X=2-BUDOPV
+26 QUIT "0^"_X_" HEP A"
+27 ;
FLU(P,BDATE,EDATE) ;EP
+1 NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
+2 ;now get imms and see if there are 4
+3 KILL BUDC,BUDG,BUDX
+4 FOR BUDZ=15,16,88,111,135,140,141,144
SET X=$$ROTACONT^BUDARP6W(P,BUDZ,EDATE)
IF X]""
QUIT
+5 IF X]""
QUIT "1^Influenza Contraindication IM package: "_$$DATE^BUDAUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+6 FOR BUDZ=15,16,88,111,135,140,141,144
SET X=$$EGGCONT^BUDARP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+7 IF X]""
QUIT "1^Influenza Contraindication IM package: "_$$DATE^BUDAUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+8 SET X=$$LASTDX^BUDAUTL1(P,"BUD ROTA CONTRA DXS",$$DOB^AUPNPAT(P),EDATE)
+9 IF X]""
QUIT "1^Influenza Contraindication: "_$PIECE(X,U,2)_" on "_$$DATE^BUDAUTL1($PIECE(X,U,3))
+10 SET X=$$PLTAX^BUDADU(P,"BUD ROTA CONTRA DXS")
IF X
QUIT "1^Influenza Contraindication: "_$PIECE(X,U,2)_" on Problem List"
+11 KILL BUDOPV,BUDAPOV
FLUIMM ;get all immunizations
+1 SET C="15^16^88^111^135^140^141^144"
+2 KILL BUDX
DO GETIMMS^BUDARP6C(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)
IF Y=90654!(Y=90655)!(Y=90657)!(Y=90660)!(Y=90661)!(Y=90662)
Begin DoDot:4
+12 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((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)
IF Y=90654!(Y=90655)!(Y=90657)!(Y=90660)!(Y=90661)!(Y=90662)
Begin DoDot:4
+15 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$$VAL^XBDIQ1(9000010.08,X,.01)
IF Y=99.52
Begin DoDot:4
+18 SET BUDOPV(9999999-$PIECE(ED,"."))="PROCEDURE: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="PROCEDURE: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+20 IF C=1
SET Y=X
QUIT
+21 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDOPV(X)
QUIT
+22 SET Y=X
End DoDot:1
+23 ;now count them and see if there are 4 of them
+24 SET BUDOPV=0
SET X=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET BUDOPV=BUDOPV+1
+25 IF BUDOPV>1
SET Y="1^Influenza: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+26 IF BUDOPV>1
QUIT Y
+27 NEW X
+28 SET X=2-BUDOPV
+29 QUIT "0^"_X_" Influenza"
+30 ;
