BUDCRP6X ; IHS/CMI/LAB - measure C ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
CNTDTAP ;
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
RESET ;RESET WORKING ARRAYS
K BUDDT M BUDDT=BUDADT
K BUDDIP M BUDDIP=BUDADIP
K BUDTET M BUDTET=BUDATET
K BUDPER M BUDPER=BUDAPER
K BUDTD M BUDTD=BUDATD
Q
RESETD ;RESET DUPES
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
K ^TMP($J,"CPT")
NEW BUDC,BUDG,BUDX,BUDDTAP,BUDTD,BUDDT,BUDDIP,BUDTET,BUDPER
;first check for contraindication
K BUDG S %=P_"^ALL DX 323.5;DURING "_BDATE_"-"_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 Contraindication DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($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 Contraindication DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($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 Contraindication DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U))
I G]"" Q G
N K BUDG S %=P_"^ALL DX 323.51;DURING "_BDATE_"-"_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 Contraindication DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($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 Contraindication DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($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 Contraindication DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U))
I G]"" Q G
N1 K BUDG S %=P_"^ALL DX 323.52;DURING "_BDATE_"-"_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 Contraindication DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($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 Contraindication DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($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 Contraindication DX/Ecode: "_$P(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U))
I G]"" Q G
N2 ;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDCTSSC("B","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 Y=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDCTSSC("AD",Y,T)) S G="1^Dtap Contraindication DX: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U))
I G]"" Q G
F BUDZ=1,20,22,50,102,106,107,110,120,130,132,28,35,112,11,146 S X=$$ANCONT^BUDCRP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^DTaP Contraindication IM package: "_$$DATE^BUDCUTL1($P(X,U))_" "_$P(X,U,2)
DTAPIM ;
;first gather up all cpt codes that relate in any way to dtap and store in ^TMP
S ED=(9999999-EDATE)-1,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
...Q:'$D(^AUPNVCPT(X,0))
...S Y=$P(^AUPNVCPT(X,0),U)
...Q:Y=""
...S Y=$P($$CPT^ICPTCOD(Y),U,2)
...I Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90720)!(Y=90698)!(Y=90702)!(Y=90719)!(Y=90703) S ^TMP($J,"CPT",9999999-$P(ED,"."),Y)=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...Q:'$D(^AUPNVTC(X,0))
...S Y=$P(^AUPNVTC(X,0),U,7)
...Q:Y=""
...S Y=$P($$CPT^ICPTCOD(Y),U,2)
...I Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90720)!(Y=90698)!(Y=90702)!(Y=90719)!(Y=90703) S ^TMP($J,"CPT",9999999-$P(ED,"."),Y)=""
;now gather up all DTAP immunizations, cpts
;get all immunizations
S C="1^20^22^50^102^106^107^110^120^130^132^146"
D GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
;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
;now get cpts for dtap or dtp
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=90698!(Y=90700)!(Y=90701)!(Y=90720)!(Y=90721)!(Y=90723) S BUDDTAP(D)="DTaP CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
D CNTDTAP ;count to see if there are 4
I BUDDTAP>3 S Y="1^DTaP: total #: "_BUDDTAP,X="" F S X=$O(BUDDTAP(X)) Q:X'=+X S Y=Y_" "_BUDDTAP(X)
I BUDDTAP>3 Q Y
K BUDG S %=P_"^ALL PROCEDURE 99.39;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDDTAP($P(BUDG(X),U))="DTaP Procedure: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U))
D CNTDTAP ;count to see if there are 4
I BUDDTAP>3 S Y="1^DTaP: total #: "_BUDDTAP,X="" F S X=$O(BUDDTAP(X)) Q:X'=+X S Y=Y_" "_BUDDTAP(X)
I BUDDTAP>3 Q Y
DT ;
;add in dt cpts
K BUDDT,BUDADT
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=90702 S BUDDT(D)="DT CPT: "_Y_" on "_$$DATE^BUDCUTL1(D),BUDADT(D)="DT CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
S C="28"
K BUDX D GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
S X=0 F S X=$O(BUDX(X)) Q:X'=+X S BUDDT(X)=BUDX(X),BUDADT(X)=BUDX(X)
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 ;
K BUDTET,BUDATET
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^BUDCUTL1($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^BUDCUTL1($P(BUDG(1),U))
I $$PLCODE^BUDCDU(P,"037.") S BUDEVTD="1^Tetanus Evidence: 037. on Problem List"
I $$PLCODE^BUDCDU(P,"A35.") 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 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=90703!(Y=90702) S BUDTET(D)="Tetanus CPT: "_Y_" on "_$$DATE^BUDCUTL1(D),BUDATET(D)="TETANUS CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
K BUDG S %=P_"^ALL PROCEDURE 99.38;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S X=0 F S X=$O(BUDG(X)) Q:X'=+X D
.S BUDTET($P(BUDG(X),U))="Tetanus Proc: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U)),BUDATET($P(BUDG(X),U))="Tetanus DX: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U))
K BUDX S C="35^112" D GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
S X=0 F S X=$O(BUDX(X)) Q:X'=+X S BUDTET(X)=BUDX(X),BUDATET(X)=BUDX(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 ;
K BUDDIP,BUDADIP
S BUDEVDIP=""
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDCTSSC("B","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(^BUDCTSSC("AD",Y,T)) S BUDEVDIP="1^Diphtheria Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U))
S X=$$PLCL^BUDCDU(P,"EVIDENCE DIPHTHERIA") 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 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=90719 S BUDDIP(D)="Diphtheria CPT: "_Y_" on "_$$DATE^BUDCUTL1(D),BUDADIP(D)="Diphtheria CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
K BUDG S %=P_"^ALL PROCEDURE 99.36;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDDIP($P(BUDG(X),U))="Diphtheria Proc: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U)),BUDADIP($P(BUDG(X),U))="Diptheria Proc: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U))
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 ;
K BUDPER,BUDAPER
S BUDPEREV=""
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDCTSSC("B","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(^BUDCTSSC("AD",Y,T)) S BUDPEREV="1^Pertussis Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U))
S X=$$PLCL^BUDCDU(P,"EVIDENCE PERTUSSIS") 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)
K BUDG S %=P_"^ALL PROCEDURE 99.37;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)) S X=0 F S X=$O(BUDG(X)) Q:X'=+X D
.S BUDPER($P(BUDG(X),U))="Pertussis Proc: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U)),BUDAPER($P(BUDG(X),U))="Pertussis Pertussis: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($P(BUDG(X),U))
K BUDX S C="11" D GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
S X=0 F S X=$O(BUDX(X)) Q:X'=+X S BUDPER(X)=BUDX(X),BUDAPER(X)=BUDX(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
CHK ;4 of each or evidence
I BUDTET>3,BUDPER>3,BUDDIP>3 D Q "1^"_Y
.S Y="4 of each"
.S X=0 F S X=$O(BUDTET(X)) Q:X'=+X S Y=Y_" "_BUDTET(X)
.S X=0 F S X=$O(BUDDIP(X)) Q:X'=+X S Y=Y_" "_BUDDIP(X)
.S X=0 F S X=$O(BUDPER(X)) Q:X'=+X S Y=Y_" "_BUDPER(X)
I BUDPEREV,BUDTET>3,BUDDIP>3 D Q "1^"_Y
.S Y="evid per, 4 tet, 4 dip "
.S Y=Y_BUDPEREV
.S X=0 F S X=$O(BUDTET(X)) Q:X'=+X S Y=Y_" "_BUDTET(X)
.S X=0 F S X=$O(BUDDIP(X)) Q:X'=+X S Y=Y_" "_BUDDIP(X)
I BUDEVTD,BUDPER>3,BUDDIP>3 D Q "1^"_Y
.S Y="evid tetanus, 4 dip, 4 per "
.S Y=Y_BUDEVTD
.S X=0 F S X=$O(BUDPER(X)) Q:X'=+X S Y=Y_" "_BUDPER(X)
.S X=0 F S X=$O(BUDDIP(X)) Q:X'=+X S Y=Y_" "_BUDDIP(X)
I BUDEVDIP,BUDTET>3,BUDPER>3 D Q "1^"_Y
.S Y="evid Diptheria, 4 tet, 4 per "
.S Y=Y_$P(BUDDIPEV,U,2)
.S X=0 F S X=$O(BUDTET(X)) Q:X'=+X S Y=Y_" "_BUDTET(X)
.S X=0 F S X=$O(BUDPER(X)) Q:X'=+X S Y=Y_" "_BUDPER(X)
I BUDEVTD,BUDEVDIP,BUDPER>3 D Q "1^"_Y
.S Y="evid tet, evid dip, 4 per "
.S Y=Y_$P(BUDEVTD,U,2)_" "_$P(BUDDIPEV,U,2)
.S X=0 F S X=$O(BUDPER(X)) Q:X'=+X S Y=Y_" "_BUDPER(X)
I BUDEVTD,BUDPEREV,BUDDIP>3 D Q "1^"_Y
.S Y="evid tet, evid PER, 4 dip "
.S Y=Y_$P(BUDEVTD,U,2)_" "_$P(BUDPEREV,U,2)
.S X=0 F S X=$O(BUDDIP(X)) Q:X'=+X S Y=Y_" "_BUDDIP(X)
I BUDEVDIP,BUDPEREV,BUDTET>3 D Q "1^"_Y
.S Y="evid dip, evid per, 4 tet "
.S Y=Y_$P(BUDDIPEV,U,2)_" "_$P(BUDPEREV,U,2)
.S X=0 F S X=$O(BUDTET(X)) Q:X'=+X S Y=Y_" "_BUDTET(X)
I BUDEVDIP,BUDPEREV,BUDEVTD D Q "1^"_Y
.S Y="evid dip, evid tet, evid per"
.S Y=Y_$P(BUDEVDIP,U,2)_" "_$P(BUDEVTD,U,2)_" "_$P(BUDPEREV,U,2)
.;S X=0 F S X=$O(BUDTET(X)) Q:X'=+X S Y=Y_" "_BUDTET(X)
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
BUDCRP6X ; IHS/CMI/LAB - measure C ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
CNTDTAP ;
+1 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+2 IF C=1
SET Y=X
QUIT
+3 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDDTAP(X)
QUIT
+4 SET Y=X
End DoDot:1
+5 ;now count
+6 SET BUDDTAP=0
SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET BUDDTAP=BUDDTAP+1
+7 QUIT
RESET ;RESET WORKING ARRAYS
+1 KILL BUDDT
MERGE BUDDT=BUDADT
+2 KILL BUDDIP
MERGE BUDDIP=BUDADIP
+3 KILL BUDTET
MERGE BUDTET=BUDATET
+4 KILL BUDPER
MERGE BUDPER=BUDAPER
+5 KILL BUDTD
MERGE BUDTD=BUDATD
+6 QUIT
RESETD ;RESET DUPES
+1 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+2 IF C=1
SET Y=X
QUIT
+3 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDDT(X)
QUIT
+4 SET Y=X
End DoDot:1
+5 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+6 IF C=1
SET Y=X
QUIT
+7 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDDIP(X)
QUIT
+8 SET Y=X
End DoDot:1
+9 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+10 IF C=1
SET Y=X
QUIT
+11 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDTET(X)
QUIT
+12 SET Y=X
End DoDot:1
+13 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDTD(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+14 IF C=1
SET Y=X
QUIT
+15 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDTD(X)
QUIT
+16 SET Y=X
End DoDot:1
+17 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDPER(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 BUDPER(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 SET BUDDT=0
SET X=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET BUDDT=BUDDT+1
+22 SET BUDTD=0
SET X=0
FOR
SET X=$ORDER(BUDTD(X))
IF X'=+X
QUIT
SET BUDTD=BUDTD+1
+23 SET BUDDIP=0
SET X=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET BUDDIP=BUDDIP+1
+24 SET BUDTET=0
SET X=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET BUDTET=BUDTET+1
+25 SET BUDPER=0
SET X=0
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET BUDPER=BUDPER+1
+26 QUIT
DTAP(P,BDATE,EDATE) ;EP
+1 KILL ^TMP($JOB,"CPT")
+2 NEW BUDC,BUDG,BUDX,BUDDTAP,BUDTD,BUDDT,BUDDIP,BUDTET,BUDPER
+3 ;first check for contraindication
+4 KILL BUDG
SET %=P_"^ALL DX 323.5;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+5 IF '$DATA(BUDG(1))
GOTO N
+6 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
+7 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.09)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^Dtap Contraindication DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
+8 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.18)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^Dtap Contraindication DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
+9 SET Z=$$VAL^XBDIQ1(9000010.07,Y,.19)
IF Z="E948.4"!(Z="E948.5")!(Z="E948.6")
SET G="1^Dtap Contraindication DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
End DoDot:1
+10 IF G]""
QUIT G
N KILL BUDG
SET %=P_"^ALL DX 323.51;DURING "_BDATE_"-"_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 Contraindication DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($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 Contraindication DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($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 Contraindication DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
End DoDot:1
+6 IF G]""
QUIT G
N1 KILL BUDG
SET %=P_"^ALL DX 323.52;DURING "_BDATE_"-"_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 Contraindication DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($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 Contraindication DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($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 Contraindication DX/Ecode: "_$PIECE(BUDG(X),U,2)_"/"_Z_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
End DoDot:1
+5 IF G]""
QUIT G
N2 ;V10.0 ICD10
+1 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+2 SET T=$ORDER(^BUDCTSSC("B","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 Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+6 IF $DATA(^BUDCTSSC("AD",Y,T))
SET G="1^Dtap Contraindication DX: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
End DoDot:1
+7 IF G]""
QUIT G
+8 FOR BUDZ=1,20,22,50,102,106,107,110,120,130,132,28,35,112,11,146
SET X=$$ANCONT^BUDCRP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+9 IF X]""
QUIT "1^DTaP Contraindication IM package: "_$$DATE^BUDCUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
DTAPIM ;
+1 ;first gather up all cpt codes that relate in any way to dtap and store in ^TMP
+2 SET ED=(9999999-EDATE)-1
SET BD=9999999-BDATE
SET G=0
+3 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+4 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+5 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+7 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+8 SET Y=$PIECE(^AUPNVCPT(X,0),U)
+9 IF Y=""
QUIT
+10 SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
+11 IF Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90720)!(Y=90698)!(Y=90702)!(Y=90719)!(Y=90703)
SET ^TMP($JOB,"CPT",9999999-$PIECE(ED,"."),Y)=""
End DoDot:3
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+13 IF '$DATA(^AUPNVTC(X,0))
QUIT
+14 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
+15 IF Y=""
QUIT
+16 SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
+17 IF Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90720)!(Y=90698)!(Y=90702)!(Y=90719)!(Y=90703)
SET ^TMP($JOB,"CPT",9999999-$PIECE(ED,"."),Y)=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;now gather up all DTAP immunizations, cpts
+19 ;get all immunizations
+20 SET C="1^20^22^50^102^106^107^110^120^130^132^146"
+21 DO GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
+22 ;go through and set into DTAP if 10 days apart
+23 SET X=0
FOR
SET X=$ORDER(BUDX(X))
IF X'=+X
QUIT
SET BUDDTAP(X)=BUDX(X)
+24 ;count to see if there are 4
DO CNTDTAP
+25 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)
+26 IF BUDDTAP>3
QUIT Y
+27 ;now get cpts for dtap or dtp
+28 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
+29 IF Y=90698!(Y=90700)!(Y=90701)!(Y=90720)!(Y=90721)!(Y=90723)
SET BUDDTAP(D)="DTaP CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
End DoDot:1
+30 ;count to see if there are 4
DO CNTDTAP
+31 IF BUDDTAP>3
SET Y="1^DTaP: total #: "_BUDDTAP
SET X=""
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDDTAP(X)
+32 IF BUDDTAP>3
QUIT Y
+33 KILL BUDG
SET %=P_"^ALL PROCEDURE 99.39;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+34 IF $DATA(BUDG(1))
SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDDTAP($PIECE(BUDG(X),U))="DTaP Procedure: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
+35 ;count to see if there are 4
DO CNTDTAP
+36 IF BUDDTAP>3
SET Y="1^DTaP: total #: "_BUDDTAP
SET X=""
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDDTAP(X)
+37 IF BUDDTAP>3
QUIT Y
DT ;
+1 ;add in dt cpts
+2 KILL BUDDT,BUDADT
+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=90702
SET BUDDT(D)="DT CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
SET BUDADT(D)="DT CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
End DoDot:1
+5 SET C="28"
+6 KILL BUDX
DO GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
+7 SET X=0
FOR
SET X=$ORDER(BUDX(X))
IF X'=+X
QUIT
SET BUDDT(X)=BUDX(X)
SET BUDADT(X)=BUDX(X)
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 KILL BUDTET,BUDATET
+2 SET BUDTET=0
+3 ;EVIDENCE?
+4 SET BUDEVTD=""
+5 KILL BUDG
SET %=P_"^LAST DX 037.;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+6 IF $DATA(BUDG(1))
SET BUDEVTD="1^Tetanus Evidence: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(1),U))
+7 KILL BUDG
SET %=P_"^LAST DX A35.;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+8 IF $DATA(BUDG(1))
SET BUDEVTD="1^Tetanus Evidence: "_$PIECE(BUDG(1),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(1),U))
+9 IF $$PLCODE^BUDCDU(P,"037.")
SET BUDEVTD="1^Tetanus Evidence: 037. on Problem List"
+10 IF $$PLCODE^BUDCDU(P,"A35.")
SET BUDEVTD="1^Tetanus Evidence: A35. on Problem List"
+11 SET X=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET BUDTET(X)=BUDDT(X)
+12 SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET BUDTET(X)=BUDDTAP(X)
+13 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
+14 IF Y=90703!(Y=90702)
SET BUDTET(D)="Tetanus CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
SET BUDATET(D)="TETANUS CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
End DoDot:1
+15 KILL BUDG
SET %=P_"^ALL PROCEDURE 99.38;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+16 IF $DATA(BUDG(1))
SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
Begin DoDot:1
+17 SET BUDTET($PIECE(BUDG(X),U))="Tetanus Proc: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
SET BUDATET($PIECE(BUDG(X),U))="Tetanus DX: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
End DoDot:1
+18 KILL BUDX
SET C="35^112"
DO GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
+19 SET X=0
FOR
SET X=$ORDER(BUDX(X))
IF X'=+X
QUIT
SET BUDTET(X)=BUDX(X)
SET BUDATET(X)=BUDX(X)
+20 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+21 IF C=1
SET Y=X
QUIT
+22 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDTET(X)
QUIT
+23 SET Y=X
End DoDot:1
+24 SET X=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET BUDTET=BUDTET+1
DIP ;
+1 KILL BUDDIP,BUDADIP
+2 SET BUDEVDIP=""
+3 ;V10.0 ICD10
+4 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+5 SET T=$ORDER(^BUDCTSSC("B","EVIDENCE DIPHTHERIA",0))
+6 SET X=0
SET BUDEVDIP=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(BUDEVDIP]"")
QUIT
Begin DoDot:1
+7 SET Y=+$PIECE(BUDG(X),U,4)
+8 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+9 IF $DATA(^BUDCTSSC("AD",Y,T))
SET BUDEVDIP="1^Diphtheria Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
End DoDot:1
+10 SET X=$$PLCL^BUDCDU(P,"EVIDENCE DIPHTHERIA")
IF X
SET BUDEVDIP="1^Diphtheria Evidence: "_$PIECE(X,U,2)_" on Problem List"
+11 SET X=0
FOR
SET X=$ORDER(BUDDT(X))
IF X'=+X
QUIT
SET BUDDIP(X)=BUDDT(X)
+12 SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET BUDDIP(X)=BUDDTAP(X)
+13 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
+14 IF Y=90719
SET BUDDIP(D)="Diphtheria CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
SET BUDADIP(D)="Diphtheria CPT: "_Y_" on "_$$DATE^BUDCUTL1(D)
End DoDot:1
+15 KILL BUDG
SET %=P_"^ALL PROCEDURE 99.36;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+16 IF $DATA(BUDG(1))
SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDDIP($PIECE(BUDG(X),U))="Diphtheria Proc: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
SET BUDADIP($PIECE(BUDG(X),U))="Diptheria Proc: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
+17 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDDIP(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 BUDDIP(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 SET X=0
SET BUDDIP=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET BUDDIP=BUDDIP+1
+22 ;
PER ;
+1 KILL BUDPER,BUDAPER
+2 SET BUDPEREV=""
+3 ;V10.0 ICD10
+4 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+5 SET T=$ORDER(^BUDCTSSC("B","EVIDENCE PERTUSSIS",0))
+6 SET X=0
SET BUDPEREV=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(BUDPEREV]"")
QUIT
Begin DoDot:1
+7 SET Y=+$PIECE(BUDG(X),U,4)
+8 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+9 IF $DATA(^BUDCTSSC("AD",Y,T))
SET BUDPEREV="1^Pertussis Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
End DoDot:1
+10 SET X=$$PLCL^BUDCDU(P,"EVIDENCE PERTUSSIS")
IF X
SET BUDPEREV="1^Pertussis Evidence: "_$PIECE(X,U,2)_" on Problem List"
+11 SET X=0
FOR
SET X=$ORDER(BUDDTAP(X))
IF X'=+X
QUIT
SET BUDPER(X)=BUDDTAP(X)
+12 KILL BUDG
SET %=P_"^ALL PROCEDURE 99.37;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+13 IF $DATA(BUDG(1))
SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
Begin DoDot:1
+14 SET BUDPER($PIECE(BUDG(X),U))="Pertussis Proc: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
SET BUDAPER($PIECE(BUDG(X),U))="Pertussis Pertussis: "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDCUTL1($PIECE(BUDG(X),U))
End DoDot:1
+15 KILL BUDX
SET C="11"
DO GETIMMS^BUDCRP6C(P,BDATE,EDATE,C,.BUDX)
+16 SET X=0
FOR
SET X=$ORDER(BUDX(X))
IF X'=+X
QUIT
SET BUDPER(X)=BUDX(X)
SET BUDAPER(X)=BUDX(X)
+17 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDPER(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 BUDPER(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 SET X=0
SET BUDPER=0
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET BUDPER=BUDPER+1
CHK ;4 of each or evidence
+1 IF BUDTET>3
IF BUDPER>3
IF BUDDIP>3
Begin DoDot:1
+2 SET Y="4 of each"
+3 SET X=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDTET(X)
+4 SET X=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDDIP(X)
+5 SET X=0
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDPER(X)
End DoDot:1
QUIT "1^"_Y
+6 IF BUDPEREV
IF BUDTET>3
IF BUDDIP>3
Begin DoDot:1
+7 SET Y="evid per, 4 tet, 4 dip "
+8 SET Y=Y_BUDPEREV
+9 SET X=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDTET(X)
+10 SET X=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDDIP(X)
End DoDot:1
QUIT "1^"_Y
+11 IF BUDEVTD
IF BUDPER>3
IF BUDDIP>3
Begin DoDot:1
+12 SET Y="evid tetanus, 4 dip, 4 per "
+13 SET Y=Y_BUDEVTD
+14 SET X=0
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDPER(X)
+15 SET X=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDDIP(X)
End DoDot:1
QUIT "1^"_Y
+16 IF BUDEVDIP
IF BUDTET>3
IF BUDPER>3
Begin DoDot:1
+17 SET Y="evid Diptheria, 4 tet, 4 per "
+18 SET Y=Y_$PIECE(BUDDIPEV,U,2)
+19 SET X=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDTET(X)
+20 SET X=0
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDPER(X)
End DoDot:1
QUIT "1^"_Y
+21 IF BUDEVTD
IF BUDEVDIP
IF BUDPER>3
Begin DoDot:1
+22 SET Y="evid tet, evid dip, 4 per "
+23 SET Y=Y_$PIECE(BUDEVTD,U,2)_" "_$PIECE(BUDDIPEV,U,2)
+24 SET X=0
FOR
SET X=$ORDER(BUDPER(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDPER(X)
End DoDot:1
QUIT "1^"_Y
+25 IF BUDEVTD
IF BUDPEREV
IF BUDDIP>3
Begin DoDot:1
+26 SET Y="evid tet, evid PER, 4 dip "
+27 SET Y=Y_$PIECE(BUDEVTD,U,2)_" "_$PIECE(BUDPEREV,U,2)
+28 SET X=0
FOR
SET X=$ORDER(BUDDIP(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDDIP(X)
End DoDot:1
QUIT "1^"_Y
+29 IF BUDEVDIP
IF BUDPEREV
IF BUDTET>3
Begin DoDot:1
+30 SET Y="evid dip, evid per, 4 tet "
+31 SET Y=Y_$PIECE(BUDDIPEV,U,2)_" "_$PIECE(BUDPEREV,U,2)
+32 SET X=0
FOR
SET X=$ORDER(BUDTET(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDTET(X)
End DoDot:1
QUIT "1^"_Y
+33 IF BUDEVDIP
IF BUDPEREV
IF BUDEVTD
Begin DoDot:1
+34 SET Y="evid dip, evid tet, evid per"
+35 SET Y=Y_$PIECE(BUDEVDIP,U,2)_" "_$PIECE(BUDEVTD,U,2)_" "_$PIECE(BUDPEREV,U,2)
+36 ;S X=0 F S X=$O(BUDTET(X)) Q:X'=+X S Y=Y_" "_BUDTET(X)
End DoDot:1
QUIT "1^"_Y
+37 SET Y="0^"
+38 IF BUDDIP<4
IF 'BUDEVDIP
SET Y=Y_(4-BUDDIP)_" DIP "
+39 IF BUDTET<4
IF 'BUDEVTD
SET Y=Y_(4-BUDTET)_" TET "
+40 IF BUDPER<4
IF 'BUDPEREV
SET Y=Y_(4-BUDPER)_" PER"
+41 QUIT Y
