BUDDRP6X ; IHS/CMI/LAB - measure C ;
;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
;
CNTDTAP ;
NEW X,Y,C
S (X,Y)="",C=0 F S X=$O(BUDDTAP(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDDTAP(X) Q
.S Y=X
;now count
S BUDDTAP=0,X=0 F S X=$O(BUDDTAP(X)) Q:X'=+X S BUDDTAP=BUDDTAP+1
Q
RESETD ;RESET DUPES
NEW X,Y,C
S (X,Y)="",C=0 F S X=$O(BUDDT(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDDT(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BUDDIP(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDDIP(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BUDTET(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDTET(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BUDTD(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDTD(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BUDPER(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDPER(X) Q
.S Y=X
S BUDDT=0,X=0 F S X=$O(BUDDT(X)) Q:X'=+X S BUDDT=BUDDT+1
S BUDTD=0,X=0 F S X=$O(BUDTD(X)) Q:X'=+X S BUDTD=BUDTD+1
S BUDDIP=0,X=0 F S X=$O(BUDDIP(X)) Q:X'=+X S BUDDIP=BUDDIP+1
S BUDTET=0,X=0 F S X=$O(BUDTET(X)) Q:X'=+X S BUDTET=BUDTET+1
S BUDPER=0,X=0 F S X=$O(BUDPER(X)) Q:X'=+X S BUDPER=BUDPER+1
Q
DTAP(P,BDATE,EDATE) ;EP
NEW BUDTET,BUDVS,TIEN,TIENDT,TIENTET,TIENDIP,TIENPER,CTR,VIEN,VDATE,X,Y,BUDX,BUDDT,BUDADT,BUDDIP,BUDPER,BUDDTAP,BUDPEREV,BUDEVTD,BUDEVIP,BUDCOTET,BUDCOPER,BUDCODIP,C,BUDG,BUDA,Z,G,A
;
DTAPIM ;
S BUDTET=0
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS") ;all visits in 42 days to end
S TIEN=$O(^BUDDTSSC("B","T6B IMM DTAP CODES",0))
S TIENDT=$O(^BUDDTSSC("B","T6B IMM DT CODES",0))
S TIENTET=$O(^BUDDTSSC("B","T6B IMM TETANUS CODES",0))
S TIENDIP=$O(^BUDDTSSC("B","T6B IMM DIPHTHERIA CODES",0))
S TIENPER=$O(^BUDDTSSC("B","T6B IMM PERTUSSIS CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.S X=0 F S X=$O(^AUPNVIMM("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVIMM(X,0))
..S Y=$$VALI^XBDIQ1(9000010.11,X,.01)
..S Y=+$P($G(^AUTTIMM(Y,0)),U,3)
..Q:'Y
..I $D(^BUDDTSSC(TIEN,15,"B",Y)) S BUDX(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC(TIENDT,15,"B",Y)) S BUDDT(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE),BUDADT(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC(TIENTET,15,"B",Y)) S BUDTET(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC(TIENDIP,15,"B",Y)) S BUDDIP(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC(TIENPER,15,"B",Y)) S BUDPER(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDX(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AC",Y,TIENDT)) S BUDDT(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE),BUDADT(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AC",Y,TIENTET)) S BUDTET(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AC",Y,TIENDIP)) S BUDDIP(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AC",Y,TIENPER)) S BUDPER(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDX(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AC",Y,TIENDT)) S BUDDT(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE),BUDADT(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AC",Y,TIENTET)) S BUDTET(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AC",Y,TIENDIP)) S BUDDIP(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AC",Y,TIENPER)) S BUDPER(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
.;V PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDDTSSC("AP",Y,TIEN)) S BUDX(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AP",Y,TIENDT)) S BUDDT(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE),BUDADT(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AP",Y,TIENTET)) S BUDTET(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AP",Y,TIENDIP)) S BUDDIP(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AP",Y,TIENPER)) S BUDPER(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDX(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AS",Y,TIENDT)) S BUDDT(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE),BUDADT(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AS",Y,TIENTET)) S BUDTET(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AS",Y,TIENDIP)) S BUDDIP(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
..I $D(^BUDDTSSC("AS",Y,TIENPER)) S BUDPER(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE) Q
;go through and set into DTAP if 10 days apart
S X=0 F S X=$O(BUDX(X)) Q:X'=+X S BUDDTAP(X)=BUDX(X)
D CNTDTAP ;count to see if there are 4
I BUDDTAP>3 S Y="1^DTap: total #: "_BUDDTAP,X=0 F S X=$O(BUDDTAP(X)) Q:X'=+X S Y=Y_" "_BUDDTAP(X)
I BUDDTAP>3 Q Y
S (BUDPEREV,BUDEVTD,BUDEVDIP,BUDCOTET,BUDCOPER,BUDCODIP)=""
;now check contra to DTap
S Y=$$CONTDTAP(P,$$DOB^AUPNPAT(P),EDATE)
I Y Q Y
DT1 ;
;kill off any that are on the same day as the dtaps
S (X,Y)="",C=0 F S X=$O(BUDDT(X)) Q:X'=+X I $D(BUDDTAP(X)) K BUDDT(X)
S (X,Y)="",C=0 F S X=$O(BUDDT(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDDT(X) Q
.S Y=X
K BUDALL
S BUDDT=0,X=0 F S X=$O(BUDDT(X)) Q:X'=+X S BUDDT=BUDDT+1,BUDALL(X)=BUDDT(X)
S BUDDTAP=0,X=0 F S X=$O(BUDDTAP(X)) Q:X'=+X S BUDDTAP=BUDDTAP+1,BUDALL(X)=BUDDTAP(X)
S (X,Y)="",C=0 F S X=$O(BUDALL(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDALL(X) Q
.S Y=X
S BUDALL=0 S X=0 F S X=$O(BUDALL(X)) Q:X'=+X S BUDALL=BUDALL+1
I BUDALL>3 D Q "1^"_Y
.S Y=">=1 DTap & DT/TdS",X=0 F S X=$O(BUDDTAP(X)) Q:X'=+X S Y=Y_" "_BUDDTAP(X)
.S X=0 F S X=$O(BUDDT(X)) Q:X'=+X S Y=Y_" "_BUDDT(X)
;
TETCVX ;
S BUDTET=0
;EVIDENCE?
S BUDEVTD=""
K BUDG S %=P_"^LAST DX 037.;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S BUDEVTD="1^Tetanus Evidence: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUDDUTL1($P(BUDG(1),U))
K BUDG S %=P_"^LAST DX A35.;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S BUDEVTD="1^Tetanus Evidence: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUDDUTL1($P(BUDG(1),U))
I $$PLCODE^BUDDDU(P,"037.",EDATE) S BUDEVTD="1^Tetanus Evidence: 037. on Problem List"
I $$PLCODE^BUDDDU(P,"A35.",EDATE) S BUDEVTD="1^Tetanus Evidence: A35. on Problem List"
S X=0 F S X=$O(BUDDT(X)) Q:X'=+X S BUDTET(X)=BUDDT(X)
S X=0 F S X=$O(BUDDTAP(X)) Q:X'=+X S BUDTET(X)=BUDDTAP(X)
S (X,Y)="",C=0 F S X=$O(BUDTET(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDTET(X) Q
.S Y=X
S X=0 F S X=$O(BUDTET(X)) Q:X'=+X S BUDTET=BUDTET+1
DIP ;
S BUDEVDIP=""
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDDTSSC("B","T6B IMM EVIDENCE DIPHTHERIA",0))
S X=0,BUDEVDIP="" F S X=$O(BUDG(X)) Q:X'=+X!(BUDEVDIP]"") D
.S Y=+$P(BUDG(X),U,4)
.S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDDTSSC("AD",Y,T)) S BUDEVDIP="1^Diphtheria Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
S X=$$PLCL^BUDDDU(P,"T6B IMM EVIDENCE DIPHTHERIA",EDATE,0) I X S BUDEVDIP="1^Diphtheria Evidence: "_$P(X,U,2)_" on Problem List"
S X=0 F S X=$O(BUDDT(X)) Q:X'=+X S BUDDIP(X)=BUDDT(X)
S X=0 F S X=$O(BUDDTAP(X)) Q:X'=+X S BUDDIP(X)=BUDDTAP(X)
S (X,Y)="",C=0 F S X=$O(BUDDIP(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDDIP(X) Q
.S Y=X
S X=0,BUDDIP=0 F S X=$O(BUDDIP(X)) Q:X'=+X S BUDDIP=BUDDIP+1
;
PER ;
S BUDPEREV=""
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDDTSSC("B","T6B IMM EVIDENCE PERTUSSIS",0))
S X=0,BUDPEREV="" F S X=$O(BUDG(X)) Q:X'=+X!(BUDPEREV]"") D
.S Y=+$P(BUDG(X),U,4)
.S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDDTSSC("AD",Y,T)) S BUDPEREV="1^Pertussis: Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
S X=$$PLCL^BUDDDU(P,"T6B IMM EVIDENCE PERTUSSIS",EDATE,0) I X S BUDPEREV="1^Pertussis: Evidence "_$P(X,U,2)_" on Problem List"
S X=0 F S X=$O(BUDDTAP(X)) Q:X'=+X S BUDPER(X)=BUDDTAP(X)
S (X,Y)="",C=0 F S X=$O(BUDPER(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDPER(X) Q
.S Y=X
S X=0,BUDPER=0 F S X=$O(BUDPER(X)) Q:X'=+X S BUDPER=BUDPER+1
I BUDPER<4,'BUDPEREV S BUDCOPER=$$CONTRA^BUDDRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDDTSSC("B","T6B IMM PERTUSSIS CODES",0)),"PERTUSSIS")
I BUDDIP<4,'BUDEVDIP S BUDCODEP=$$CONTRA^BUDDRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDDTSSC("B","T6B IMM DIPHTHERIA CODES",0)),"DIPHTHERIA")
I BUDTET<4,'BUDEVTD S BUDCOTET=$$CONTRA^BUDDRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDDTSSC("B","T6B IMM TETANUS CODES",0)),"TETANUS")
CHK ;4 of each or evidence
S BUDA(1)=$P(BUDEVDIP,U)_U_"DIP: Evidence"_U_$P(BUDEVDIP,U,2)
S X=0,Y="" F S X=$O(BUDDIP(X)) Q:X'=+X S Y=Y_" "_BUDDIP(X)
S BUDA(2)=$S(BUDDIP>3:1,1:0)_U_"DIP: total #: 4"_U_Y
S BUDA(3)=$P(BUDCODIP,U)_U_"DIP: CONTRA"_U_$P(BUDCODIP,U,2)
;
S BUDA(4)=$P(BUDEVTD,U)_U_"Tetanus: Evidence"_U_$P(BUDEVTD,U,2)
S X=0,Y="" F S X=$O(BUDETT(X)) Q:X'=+X S Y=Y_" "_BUDTET(X)
S BUDA(5)=$S(BUDTET>3:1,1:0)_U_"Tetanus: total #: 4"_U_Y
S BUDA(6)=$P(BUDCOTET,U)_U_"Tetanus: CONTRA"_U_$P(BUDCOTET,U,2)
;
S BUDA(7)=$P(BUDPEREV,U)_U_"Perussis: Evidence"_U_$P(BUDPEREV,U,2)
S X=0,Y="" F S X=$O(BUDPER(X)) Q:X'=+X S Y=Y_" "_BUDPER(X)
S BUDA(8)=$S(BUDPER>3:1,1:0)_U_"Pertussis: total #: 4"_U_Y
S BUDA(9)=$P(BUDCOPER,U)_U_"Pertussis: CONTRA"_U_$P(BUDCOPER,U,2)
;
S G=""
F X=1,2,3 D Q:G]""
.F Y=4,5,6 D Q:G]""
..F Z=7,8,9 D Q:G]""
...I $P(BUDA(X),U,1),$P(BUDA(Y),U,1),$P(BUDA(Z),U,1) D
....S G=1_U_$P(BUDA(X),U,2)_", "_$P(BUDA(Y),U,2)_", "_$P(BUDA(Z),U,2)
....S A="",A=$P(BUDA(X),U,3)_", "_$P(BUDA(Y),U,3)_", "_$P(BUDA(Z),U,3)
....S G=G_" "_A
I G]"" Q G
S Y="0^"
I BUDDIP<4,'BUDEVDIP S Y=Y_(4-BUDDIP)_" DIP "
I BUDTET<4,'BUDEVTD S Y=Y_(4-BUDTET)_" TET "
I BUDPER<4,'BUDPEREV S Y=Y_(4-BUDPER)_" PER"
Q Y
CONTDTAP(P,BDATE,EDATE) ;
NEW BUDG,X,G,Z,E,%,T,S,BUDZ
;first check for contraindication
K BUDG S %=P_"^ALL DX 323.5;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I '$D(BUDG(1)) G N
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G]"") S Y=+$P(BUDG(X),U,4) D
.S Z=$$VAL^XBDIQ1(9000010.07,Y,.09) I Z="E948.4"!(Z="E948.5")!(Z="E948.6") S G="1^DTAP: CONTRA DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
.S Z=$$VAL^XBDIQ1(9000010.07,Y,.18) I Z="E948.4"!(Z="E948.5")!(Z="E948.6") S G="1^DTAP: CONTRA DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
.S Z=$$VAL^XBDIQ1(9000010.07,Y,.19) I Z="E948.4"!(Z="E948.5")!(Z="E948.6") S G="1^DTAP: CONTRA DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
I G]"" Q G
N K BUDG S %=P_"^ALL DX 323.51;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I '$D(BUDG(1)) G N1
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G]"") S Y=+$P(BUDG(X),U,4) D
.S Z=$$VAL^XBDIQ1(9000010.07,Y,.09) I Z="E948.4"!(Z="E948.5")!(Z="E948.6") S G="1^DTAP: CONTRA DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
.S Z=$$VAL^XBDIQ1(9000010.07,Y,.18) I Z="E948.4"!(Z="E948.5")!(Z="E948.6") S G="1^DTAP: CONTRA DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
.S Z=$$VAL^XBDIQ1(9000010.07,Y,.19) I Z="E948.4"!(Z="E948.5")!(Z="E948.6") S G="1^DTAP: CONTRA DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
I G]"" Q G
N1 K BUDG S %=P_"^ALL DX 323.52;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G]"") S Y=+$P(BUDG(X),U,4) D
.S Z=$$VAL^XBDIQ1(9000010.07,Y,.09) I Z="E948.4"!(Z="E948.5")!(Z="E948.6") S G="1^DTAP: CONTRA DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
.S Z=$$VAL^XBDIQ1(9000010.07,Y,.18) I Z="E948.4"!(Z="E948.5")!(Z="E948.6") S G="1^DTAP: CONTRA DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
.S Z=$$VAL^XBDIQ1(9000010.07,Y,.19) I Z="E948.4"!(Z="E948.5")!(Z="E948.6") S G="1^DTAP: CONTRA DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U))
I G]"" Q G
N2 ;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDDTSSC("B","T6B IMM CONTRA DTAP/DTP",0))
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G]"") D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDDTSSC("AD",Z,T)) S G="1^DTAP: CONTRA DX "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U)) Q
.S S=$$VALI^XBDIQ1(9000010.07,Y,1101)
.I S]"",$D(^BUDDTSSC(T,13,"B",S)) S G="1^DTAP: CONTRA DX/SNOMED "_S_" on "_$$DATE^BUDDUTL1($P(BUDG(X),U)) Q
K BUDG
I G]"" Q G
S BUDZ=0,X=""
F S BUDZ=$O(^BUDDTSSC(T,15,"B",BUDZ)) Q:BUDZ=""!(X]"") S X=$$ANCONT^BUDDRP6C(P,BUDZ,EDATE)
I X]"" Q "1^DTAP: CONTRA IMM package: "_$$DATE^BUDDUTL1($P(X,U))_" "_$P(X,U,2)
S X=$$CONTRA^BUDDRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDDTSSC("B","T6B IMM CONTRA DTAP/DTP",0)),"DTAP")
I X Q X
S X=$$PLCL^BUDDDU(P,"T6B IMM CONTRA DTAP/DTP",EDATE,0) I X Q "1^DTAP: CONTRA "_$P(X,U,2)_" on Problem List"
Q ""
BUDDRP6X ; IHS/CMI/LAB - measure C ;
+1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
+2 ;
CNTDTAP ;
+1 NEW X,Y,C
+2 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+3 IF C=1
SET Y=X
QUIT
+4 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDDTAP(X)
QUIT
+5 SET Y=X
End DoDot:1
+6 ;now count
+7 SET BUDDTAP=0
SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET BUDDTAP=BUDDTAP+1
+8 QUIT
RESETD ;RESET DUPES
+1 NEW X,Y,C
+2 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+3 IF C=1
SET Y=X
QUIT
+4 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDDT(X)
QUIT
+5 SET Y=X
End DoDot:1
+6 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+7 IF C=1
SET Y=X
QUIT
+8 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDDIP(X)
QUIT
+9 SET Y=X
End DoDot:1
+10 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+11 IF C=1
SET Y=X
QUIT
+12 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDTET(X)
QUIT
+13 SET Y=X
End DoDot:1
+14 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDTD(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+15 IF C=1
SET Y=X
QUIT
+16 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDTD(X)
QUIT
+17 SET Y=X
End DoDot:1
+18 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+19 IF C=1
SET Y=X
QUIT
+20 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDPER(X)
QUIT
+21 SET Y=X
End DoDot:1
+22 SET BUDDT=0
SET X=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET BUDDT=BUDDT+1
+23 SET BUDTD=0
SET X=0
FOR
SET X=$ORDER(BUDTD(X))
IF X'=+X
QUIT
SET BUDTD=BUDTD+1
+24 SET BUDDIP=0
SET X=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET BUDDIP=BUDDIP+1
+25 SET BUDTET=0
SET X=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET BUDTET=BUDTET+1
+26 SET BUDPER=0
SET X=0
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET BUDPER=BUDPER+1
+27 QUIT
DTAP(P,BDATE,EDATE) ;EP
+1 NEW BUDTET,BUDVS,TIEN,TIENDT,TIENTET,TIENDIP,TIENPER,CTR,VIEN,VDATE,X,Y,BUDX,BUDDT,BUDADT,BUDDIP,BUDPER,BUDDTAP,BUDPEREV,BUDEVTD,BUDEVIP,BUDCOTET,BUDCOPER,BUDCODIP,C,BUDG,BUDA,Z,G,A
+2 ;
DTAPIM ;
+1 SET BUDTET=0
+2 ;all visits in 42 days to end
DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+3 SET TIEN=$ORDER(^BUDDTSSC("B","T6B IMM DTAP CODES",0))
+4 SET TIENDT=$ORDER(^BUDDTSSC("B","T6B IMM DT CODES",0))
+5 SET TIENTET=$ORDER(^BUDDTSSC("B","T6B IMM TETANUS CODES",0))
+6 SET TIENDIP=$ORDER(^BUDDTSSC("B","T6B IMM DIPHTHERIA CODES",0))
+7 SET TIENPER=$ORDER(^BUDDTSSC("B","T6B IMM PERTUSSIS CODES",0))
+8 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+9 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+10 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVIMM(X,0))
QUIT
+13 SET Y=$$VALI^XBDIQ1(9000010.11,X,.01)
+14 SET Y=+$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+15 IF 'Y
QUIT
+16 IF $DATA(^BUDDTSSC(TIEN,15,"B",Y))
SET BUDX(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+17 IF $DATA(^BUDDTSSC(TIENDT,15,"B",Y))
SET BUDDT(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
SET BUDADT(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+18 IF $DATA(^BUDDTSSC(TIENTET,15,"B",Y))
SET BUDTET(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+19 IF $DATA(^BUDDTSSC(TIENDIP,15,"B",Y))
SET BUDDIP(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+20 IF $DATA(^BUDDTSSC(TIENPER,15,"B",Y))
SET BUDPER(VDATE)="CVX "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
End DoDot:2
+21 ;CPT
+22 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+23 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+24 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+25 IF Y=""
QUIT
+26 IF $DATA(^BUDDTSSC("AC",Y,TIEN))
SET BUDX(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+27 IF $DATA(^BUDDTSSC("AC",Y,TIENDT))
SET BUDDT(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
SET BUDADT(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+28 IF $DATA(^BUDDTSSC("AC",Y,TIENTET))
SET BUDTET(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+29 IF $DATA(^BUDDTSSC("AC",Y,TIENDIP))
SET BUDDIP(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+30 IF $DATA(^BUDDTSSC("AC",Y,TIENPER))
SET BUDPER(VDATE)="CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
End DoDot:2
+31 ;V TRANS
+32 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+33 IF '$DATA(^AUPNVTC(X,0))
QUIT
+34 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+35 IF Y=""
QUIT
+36 IF $DATA(^BUDDTSSC("AC",Y,TIEN))
SET BUDX(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+37 IF $DATA(^BUDDTSSC("AC",Y,TIENDT))
SET BUDDT(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
SET BUDADT(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+38 IF $DATA(^BUDDTSSC("AC",Y,TIENTET))
SET BUDTET(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+39 IF $DATA(^BUDDTSSC("AC",Y,TIENDIP))
SET BUDDIP(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+40 IF $DATA(^BUDDTSSC("AC",Y,TIENPER))
SET BUDPER(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
End DoDot:2
+41 ;V PROC
+42 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+43 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+44 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+45 IF $DATA(^BUDDTSSC("AP",Y,TIEN))
SET BUDX(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+46 IF $DATA(^BUDDTSSC("AP",Y,TIENDT))
SET BUDDT(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
SET BUDADT(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+47 IF $DATA(^BUDDTSSC("AP",Y,TIENTET))
SET BUDTET(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+48 IF $DATA(^BUDDTSSC("AP",Y,TIENDIP))
SET BUDDIP(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+49 IF $DATA(^BUDDTSSC("AP",Y,TIENPER))
SET BUDPER(VDATE)="PROC "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
End DoDot:2
+50 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+51 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+52 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+53 IF Y=""
QUIT
+54 IF $DATA(^BUDDTSSC("AS",Y,TIEN))
SET BUDX(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+55 IF $DATA(^BUDDTSSC("AS",Y,TIENDT))
SET BUDDT(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
SET BUDADT(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+56 IF $DATA(^BUDDTSSC("AS",Y,TIENTET))
SET BUDTET(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+57 IF $DATA(^BUDDTSSC("AS",Y,TIENDIP))
SET BUDDIP(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
+58 IF $DATA(^BUDDTSSC("AS",Y,TIENPER))
SET BUDPER(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
QUIT
End DoDot:2
End DoDot:1
+59 ;go through and set into DTAP if 10 days apart
+60 SET X=0
FOR
SET X=$ORDER(BUDX(X))
IF X'=+X
QUIT
SET BUDDTAP(X)=BUDX(X)
+61 ;count to see if there are 4
DO CNTDTAP
+62 IF BUDDTAP>3
SET Y="1^DTap: total #: "_BUDDTAP
SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDDTAP(X)
+63 IF BUDDTAP>3
QUIT Y
+64 SET (BUDPEREV,BUDEVTD,BUDEVDIP,BUDCOTET,BUDCOPER,BUDCODIP)=""
+65 ;now check contra to DTap
+66 SET Y=$$CONTDTAP(P,$$DOB^AUPNPAT(P),EDATE)
+67 IF Y
QUIT Y
DT1 ;
+1 ;kill off any that are on the same day as the dtaps
+2 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
IF $DATA(BUDDTAP(X))
KILL BUDDT(X)
+3 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+4 IF C=1
SET Y=X
QUIT
+5 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDDT(X)
QUIT
+6 SET Y=X
End DoDot:1
+7 KILL BUDALL
+8 SET BUDDT=0
SET X=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET BUDDT=BUDDT+1
SET BUDALL(X)=BUDDT(X)
+9 SET BUDDTAP=0
SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET BUDDTAP=BUDDTAP+1
SET BUDALL(X)=BUDDTAP(X)
+10 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDALL(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+11 IF C=1
SET Y=X
QUIT
+12 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDALL(X)
QUIT
+13 SET Y=X
End DoDot:1
+14 SET BUDALL=0
SET X=0
FOR
SET X=$ORDER(BUDALL(X))
IF X'=+X
QUIT
SET BUDALL=BUDALL+1
+15 IF BUDALL>3
Begin DoDot:1
+16 SET Y=">=1 DTap & DT/TdS"
SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDDTAP(X)
+17 SET X=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDDT(X)
End DoDot:1
QUIT "1^"_Y
+18 ;
TETCVX ;
+1 SET BUDTET=0
+2 ;EVIDENCE?
+3 SET BUDEVTD=""
+4 KILL BUDG
SET %=P_"^LAST DX 037.;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+5 IF $DATA(BUDG(1))
SET BUDEVTD="1^Tetanus Evidence: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(1),U))
+6 KILL BUDG
SET %=P_"^LAST DX A35.;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+7 IF $DATA(BUDG(1))
SET BUDEVTD="1^Tetanus Evidence: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(1),U))
+8 IF $$PLCODE^BUDDDU(P,"037.",EDATE)
SET BUDEVTD="1^Tetanus Evidence: 037. on Problem List"
+9 IF $$PLCODE^BUDDDU(P,"A35.",EDATE)
SET BUDEVTD="1^Tetanus Evidence: A35. on Problem List"
+10 SET X=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET BUDTET(X)=BUDDT(X)
+11 SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET BUDTET(X)=BUDDTAP(X)
+12 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+13 IF C=1
SET Y=X
QUIT
+14 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDTET(X)
QUIT
+15 SET Y=X
End DoDot:1
+16 SET X=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET BUDTET=BUDTET+1
DIP ;
+1 SET BUDEVDIP=""
+2 ;V10.0 ICD10
+3 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+4 SET T=$ORDER(^BUDDTSSC("B","T6B IMM EVIDENCE DIPHTHERIA",0))
+5 SET X=0
SET BUDEVDIP=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(BUDEVDIP]"")
QUIT
Begin DoDot:1
+6 SET Y=+$PIECE(BUDG(X),U,4)
+7 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+8 IF $DATA(^BUDDTSSC("AD",Y,T))
SET BUDEVDIP="1^Diphtheria Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
End DoDot:1
+9 SET X=$$PLCL^BUDDDU(P,"T6B IMM EVIDENCE DIPHTHERIA",EDATE,0)
IF X
SET BUDEVDIP="1^Diphtheria Evidence: "_$PIECE(X,U,2)_" on Problem List"
+10 SET X=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET BUDDIP(X)=BUDDT(X)
+11 SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET BUDDIP(X)=BUDDTAP(X)
+12 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+13 IF C=1
SET Y=X
QUIT
+14 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDDIP(X)
QUIT
+15 SET Y=X
End DoDot:1
+16 SET X=0
SET BUDDIP=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET BUDDIP=BUDDIP+1
+17 ;
PER ;
+1 SET BUDPEREV=""
+2 ;V10.0 ICD10
+3 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+4 SET T=$ORDER(^BUDDTSSC("B","T6B IMM EVIDENCE PERTUSSIS",0))
+5 SET X=0
SET BUDPEREV=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(BUDPEREV]"")
QUIT
Begin DoDot:1
+6 SET Y=+$PIECE(BUDG(X),U,4)
+7 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+8 IF $DATA(^BUDDTSSC("AD",Y,T))
SET BUDPEREV="1^Pertussis: Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
End DoDot:1
+9 SET X=$$PLCL^BUDDDU(P,"T6B IMM EVIDENCE PERTUSSIS",EDATE,0)
IF X
SET BUDPEREV="1^Pertussis: Evidence "_$PIECE(X,U,2)_" on Problem List"
+10 SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET BUDPER(X)=BUDDTAP(X)
+11 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+12 IF C=1
SET Y=X
QUIT
+13 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDPER(X)
QUIT
+14 SET Y=X
End DoDot:1
+15 SET X=0
SET BUDPER=0
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET BUDPER=BUDPER+1
+16 IF BUDPER<4
IF 'BUDPEREV
SET BUDCOPER=$$CONTRA^BUDDRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDDTSSC("B","T6B IMM PERTUSSIS CODES",0)),"PERTUSSIS")
+17 IF BUDDIP<4
IF 'BUDEVDIP
SET BUDCODEP=$$CONTRA^BUDDRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDDTSSC("B","T6B IMM DIPHTHERIA CODES",0)),"DIPHTHERIA")
+18 IF BUDTET<4
IF 'BUDEVTD
SET BUDCOTET=$$CONTRA^BUDDRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDDTSSC("B","T6B IMM TETANUS CODES",0)),"TETANUS")
CHK ;4 of each or evidence
+1 SET BUDA(1)=$PIECE(BUDEVDIP,U)_U_"DIP: Evidence"_U_$PIECE(BUDEVDIP,U,2)
+2 SET X=0
SET Y=""
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDDIP(X)
+3 SET BUDA(2)=$SELECT(BUDDIP>3:1,1:0)_U_"DIP: total #: 4"_U_Y
+4 SET BUDA(3)=$PIECE(BUDCODIP,U)_U_"DIP: CONTRA"_U_$PIECE(BUDCODIP,U,2)
+5 ;
+6 SET BUDA(4)=$PIECE(BUDEVTD,U)_U_"Tetanus: Evidence"_U_$PIECE(BUDEVTD,U,2)
+7 SET X=0
SET Y=""
FOR
SET X=$ORDER(BUDETT(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDTET(X)
+8 SET BUDA(5)=$SELECT(BUDTET>3:1,1:0)_U_"Tetanus: total #: 4"_U_Y
+9 SET BUDA(6)=$PIECE(BUDCOTET,U)_U_"Tetanus: CONTRA"_U_$PIECE(BUDCOTET,U,2)
+10 ;
+11 SET BUDA(7)=$PIECE(BUDPEREV,U)_U_"Perussis: Evidence"_U_$PIECE(BUDPEREV,U,2)
+12 SET X=0
SET Y=""
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDPER(X)
+13 SET BUDA(8)=$SELECT(BUDPER>3:1,1:0)_U_"Pertussis: total #: 4"_U_Y
+14 SET BUDA(9)=$PIECE(BUDCOPER,U)_U_"Pertussis: CONTRA"_U_$PIECE(BUDCOPER,U,2)
+15 ;
+16 SET G=""
+17 FOR X=1,2,3
Begin DoDot:1
+18 FOR Y=4,5,6
Begin DoDot:2
+19 FOR Z=7,8,9
Begin DoDot:3
+20 IF $PIECE(BUDA(X),U,1)
IF $PIECE(BUDA(Y),U,1)
IF $PIECE(BUDA(Z),U,1)
Begin DoDot:4
+21 SET G=1_U_$PIECE(BUDA(X),U,2)_", "_$PIECE(BUDA(Y),U,2)_", "_$PIECE(BUDA(Z),U,2)
+22 SET A=""
SET A=$PIECE(BUDA(X),U,3)_", "_$PIECE(BUDA(Y),U,3)_", "_$PIECE(BUDA(Z),U,3)
+23 SET G=G_" "_A
End DoDot:4
End DoDot:3
IF G]""
QUIT
End DoDot:2
IF G]""
QUIT
End DoDot:1
IF G]""
QUIT
+24 IF G]""
QUIT G
+25 SET Y="0^"
+26 IF BUDDIP<4
IF 'BUDEVDIP
SET Y=Y_(4-BUDDIP)_" DIP "
+27 IF BUDTET<4
IF 'BUDEVTD
SET Y=Y_(4-BUDTET)_" TET "
+28 IF BUDPER<4
IF 'BUDPEREV
SET Y=Y_(4-BUDPER)_" PER"
+29 QUIT Y
CONTDTAP(P,BDATE,EDATE) ;
+1 NEW BUDG,X,G,Z,E,%,T,S,BUDZ
+2 ;first check for contraindication
+3 KILL BUDG
SET %=P_"^ALL DX 323.5;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+4 IF '$DATA(BUDG(1))
GOTO N
+5 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
SET Y=+$PIECE(BUDG(X),U,4)
Begin DoDot:1
+6 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.09)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^DTAP: CONTRA DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
+7 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.18)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^DTAP: CONTRA DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
+8 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.19)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^DTAP: CONTRA DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
End DoDot:1
+9 IF G]""
QUIT G
N KILL BUDG
SET %=P_"^ALL DX 323.51;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+1 IF '$DATA(BUDG(1))
GOTO N1
+2 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
SET Y=+$PIECE(BUDG(X),U,4)
Begin DoDot:1
+3 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.09)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^DTAP: CONTRA DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
+4 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.18)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^DTAP: CONTRA DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
+5 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.19)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^DTAP: CONTRA DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
End DoDot:1
+6 IF G]""
QUIT G
N1 KILL BUDG
SET %=P_"^ALL DX 323.52;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+1 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
SET Y=+$PIECE(BUDG(X),U,4)
Begin DoDot:1
+2 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.09)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^DTAP: CONTRA DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
+3 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.18)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^DTAP: CONTRA DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
+4 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.19)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^DTAP: CONTRA DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
End DoDot:1
+5 IF G]""
QUIT G
N2 ;V10.0 ICD10
+1 KILL BUDG
SET %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+2 SET T=$ORDER(^BUDDTSSC("B","T6B IMM CONTRA DTAP/DTP",0))
+3 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+4 SET Y=+$PIECE(BUDG(X),U,4)
+5 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+6 IF $DATA(^BUDDTSSC("AD",Z,T))
SET G="1^DTAP: CONTRA DX "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
QUIT
+7 SET S=$$VALI^XBDIQ1(9000010.07,Y,1101)
+8 IF S]""
IF $DATA(^BUDDTSSC(T,13,"B",S))
SET G="1^DTAP: CONTRA DX/SNOMED "_S_" on "_$$DATE^BUDDUTL1($PIECE(BUDG(X),U))
QUIT
End DoDot:1
+9 KILL BUDG
+10 IF G]""
QUIT G
+11 SET BUDZ=0
SET X=""
+12 FOR
SET BUDZ=$ORDER(^BUDDTSSC(T,15,"B",BUDZ))
IF BUDZ=""!(X]"")
QUIT
SET X=$$ANCONT^BUDDRP6C(P,BUDZ,EDATE)
+13 IF X]""
QUIT "1^DTAP: CONTRA IMM package: "_$$DATE^BUDDUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+14 SET X=$$CONTRA^BUDDRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDDTSSC("B","T6B IMM CONTRA DTAP/DTP",0)),"DTAP")
+15 IF X
QUIT X
+16 SET X=$$PLCL^BUDDDU(P,"T6B IMM CONTRA DTAP/DTP",EDATE,0)
IF X
QUIT "1^DTAP: CONTRA "_$PIECE(X,U,2)_" on Problem List"
+17 QUIT ""
