BGP4D86 ; IHS/CMI/LAB - measure C 06 Nov 2009 2:26 PM ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
IRAR ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
I 'BGPACTCL S BGPSTOP=1 Q
I BGPAGEB<16 S BGPSTOP=1 Q ;must be 16 or older
I '$$RHEUAR^BGP4D862(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q ;no OSTEOARTHRITIS
S BGPV=$$MEDSPRE^BGP4D863(DFN,BGPBDATE,BGPEDATE)
I '$P(BGPV,U) S BGPSTOP=1 K ^TMP($J,"A"),BGPMEDS1 Q ;no meds prescribed per logic
S BGPN1=0
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
I 'BGPD1 S BGPSTOP=1 Q
K BGPIRZ,BGPIRV
I $P(BGPV,U,2) D
.S BGPCBC=$$CBC^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.S BGPLFT=$$LFT^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.S BGPCREAT=$$CREAT^BGP4D22(DFN,BGPBDATE,BGPEDATE)
.S BGPIRZ("A")=0,BGPIRV("A")="NSAID: "
.I BGPCBC,BGPLFT,BGPCREAT S BGPIRZ("A")=1 ;,BGPIRV("A")=BGPIRV("A")_$$DATE^BGP4UTL($P(BGPCREAT,U,2))_" CREAT, "_$$DATE^BGP4UTL($P(BGPCBC,U,2))_" CBC, "_$$DATE^BGP4UTL($P(BGPLFT,U,2))_" LFT" ;NA MEDS AND HAS CBC,LFT
.I BGPCREAT S BGPIRV("A")=BGPIRV("A")_$$DATE^BGP4UTL($P(BGPCREAT,U,2))_" CREAT"
.I BGPCBC S BGPIRV("A")=BGPIRV("A")_$S(BGPIRV("A")]"":", ",1:"") S BGPIRV("A")=BGPIRV("A")_$$DATE^BGP4UTL($P(BGPCBC,U,2))_" CBC"
.I BGPLFT S BGPIRV("A")=BGPIRV("A")_$S(BGPIRV("A")]"":", ",1:"") S BGPIRV("A")=BGPIRV("A")_$$DATE^BGP4UTL($P(BGPLFT,U,2))_" LFT"
I $P(BGPV,U,3) D
.S BGPGOLD=$$GOLDLAB^BGP4D864(DFN,BGPBDATE,BGPEDATE)
.S BGPIRZ("B")=0,BGPIRV("B")="IM Gold: "
.I BGPGOLD S BGPIRZ("B")=1,BGPIRV("B")=BGPIRV("B")_" "_$P(BGPGOLD,U,2)
.I 'BGPGOLD S BGPIRV("B")=$P(BGPGOLD,U,2)
I $P(BGPV,U,4) D
.S BGPCBC=$$CBC4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.S BGPIRZ("C")=0,BGPIRV("C")="AZATHIOPRINE: "
.I BGPCBC S BGPIRZ("C")=1,BGPIRV("C")=BGPIRV("C")_"has 4 CBC's"
.I 'BGPCBC S BGPIRV("C")=BGPIRV("C")_" does not have 4 CBC's"
I $P(BGPV,U,5) D
.S BGPCBC=$$CBC6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.S BGPIRZ("D")=0,BGPIRV("D")="Leflunomide: "
.I BGPCBC S BGPIRV("D")=BGPIRV("D")_"has 6 CBC's"
.I 'BGPCBC S BGPIRV("D")=BGPIRV("D")_" does not have 6 CBC's"
.S BGPSERUM=$$SERUM6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.I BGPSERUM S BGPIRV("D")=BGPIRV("D")_" has 6 Serum Creatinine's"
.I 'BGPSERUM S BGPIRV("D")=BGPIRV("D")_" does not have 6 Serum Creatinine's"
.S BGPLFT=$$LFT6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.I BGPLFT S BGPIRV("D")=BGPIRV("D")_" has 6 LFT's"
.I 'BGPLFT S BGPIRV("D")=BGPIRV("D")_" does not have 6 LFT's"
.I BGPCBC,BGPSERUM,BGPLFT S BGPIRZ("D")=1
I $P(BGPV,U,6) D
.S BGPCBC=$$CBC6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.S BGPIRZ("E")=0,BGPIRV("E")="Methotrexate: "
.I BGPCBC S BGPIRV("E")=BGPIRV("E")_"has 6 CBC's"
.I 'BGPCBC S BGPIRV("E")=BGPIRV("E")_" does not have 6 CBC's"
.S BGPSERUM=$$SERUM6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.I BGPSERUM S BGPIRV("E")=BGPIRV("E")_" has 6 Serum Creatinine's"
.I 'BGPSERUM S BGPIRV("E")=BGPIRV("E")_" does not have 6 Serum Creatinine's"
.S BGPLFT=$$LFT6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.I BGPLFT S BGPIRV("E")=BGPIRV("E")_" has 6 LFT's"
.I 'BGPLFT S BGPIRV("E")=BGPIRV("E")_" does not have 6 LFT's"
.I BGPCBC,BGPSERUM,BGPLFT S BGPIRZ("E")=1
I $P(BGPV,U,7) D
.S BGPCBC=$$CBC^BGP4D861(DFN,$$FMADD^XLFDT(BGPEDATE,-180),BGPEDATE)
.S BGPIRZ("F")=0,BGPIRV("F")="Cycolsporin: "
.I BGPCBC S BGPIRV("F")=BGPIRV("F")_"has CBC Past 180 days"
.I 'BGPCBC S BGPIRV("F")=BGPIRV("F")_" does not have CBC past 180 days"
.S BGPLFT=$$LFT^BGP4D861(DFN,$$FMADD^XLFDT(BGPBDATE,-180),BGPEDATE)
.I BGPLFT S BGPIRV("F")=BGPIRV("F")_" has LFT past 180 days"
.I 'BGPLFT S BGPIRV("F")=BGPIRV("F")_" does not have LFT 180 days"
.S BGPPOT=$$POT^BGP4D861(DFN,$$FMADD^XLFDT(BGPBDATE,-180),BGPEDATE)
.I BGPPOT S BGPIRV("F")=BGPIRV("F")_" has Potassium in 180 days"
.I 'BGPPOT S BGPIRV("F")=BGPIRV("F")_" does not have Potassium"
.S BGPSERUM=$$SERUM12^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.I BGPSERUM S BGPIRV("F")=BGPIRV("F")_" has 12 serum creatinine"
.I 'BGPSERUM S BGPIRV("F")=BGPIRV("F")_" does not have 12 serum creatinine"
.I BGPCBC,BGPSERUM,BGPLFT,BGPPOT S BGPIRZ("F")=1
I $P(BGPV,U,8) D
.S BGPCBC=$$CBC4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.S BGPIRZ("G")=0,BGPIRV("G")="Oral Gold: "
.I BGPCBC S BGPIRV("G")=BGPIRV("G")_"has 4 CBC's"
.I 'BGPCBC S BGPIRV("G")=BGPIRV("G")_" does not have 6 CBC's"
.S BGPUP=$$UP4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.I BGPUP S BGPIRV("G")=BGPIRV("G")_" has 4 Urine Proteins"
.I 'BGPUP S BGPIRV("G")=BGPIRV("G")_" does not have 4 Urine Protein's"
.I BGPCBC,BGPUP S BGPIRZ("G")=1
I $P(BGPV,U,9) D
.S BGPCBC=$$CBC^BGP4D861(DFN,$$FMADD^XLFDT(BGPEDATE,-180),BGPEDATE)
.S BGPIRZ("H")=0,BGPIRV("H")="Mycophenolate: "
.I BGPCBC S BGPIRV("H")=BGPIRV("H")_"has CBC Past 180 days"
.I 'BGPCBC S BGPIRV("H")=BGPIRV("H")_" does not have CBC past 180 days"
.I BGPCBC S BGPIRZ("H")=1
I $P(BGPV,U,10) D
.S BGPCBC=$$CBC4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.S BGPIRZ("I")=0,BGPIRV("I")="Penicillamine: "
.I BGPCBC S BGPIRV("I")=BGPIRV("I")_"has 4 CBC's"
.I 'BGPCBC S BGPIRV("I")=BGPIRV("I")_" does not have 6 CBC's"
.S BGPUP=$$UP4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.I BGPUP S BGPIRV("I")=BGPIRV("I")_" has 4 Urine Proteins"
.I 'BGPUP S BGPIRV("I")=BGPIRV("I")_" does not have 4 Urine Protein's"
.I BGPCBC,BGPUP S BGPIRZ("I")=1
I $P(BGPV,U,11) D
.S BGPCBC=$$CBC4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.S BGPIRZ("J")=0,BGPIRV("J")="Sulfasalazine: "
.I BGPCBC S BGPIRZ("J")=1,BGPIRV("J")=BGPIRV("J")_"has 4 CBC's"
.I 'BGPCBC S BGPIRV("J")=BGPIRV("J")_" does not have 4 CBC's"
I $P(BGPV,U,12) D
.S BGPGLU=$$GLUCOSE^BGP4D861(DFN,BGPBDATE,BGPEDATE)
.S BGPIRZ("K")=0,BGPIRV("K")="Glucocorticoids: "
.I BGPGLU S BGPIRZ("K")=1,BGPIRV("K")=BGPIRV("K")_$$DATE^BGP4UTL($P(BGPGLU,U,2))_" Glucose"
.I 'BGPGLU S BGPIRV("K")=BGPIRV("K")_" does not have Glucose"
S BGPN1=1 S X="" F S X=$O(BGPIRZ(X)) Q:X="" I BGPIRZ(X)=0 S BGPN1=0
S BGPVALUE=$S(BGPD1:"AC",1:"")_"|||"
S BGPVALUE=BGPVALUE_$S(BGPN1:"YES: ",1:"NO: ") S X="" F S X=$O(BGPIRV(X)) Q:X="" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,U,2)]"":"; ",1:""),BGPVALUE=BGPVALUE_BGPIRV(X)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
K ^TMP($J,"A")
Q
;
TDAP(P,EDATE) ;EP
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPVARI
;get all immunizations
S C="115"
D GETIMMS^BGP4D32(P,EDATE,C,.BGPX)
;go through and set into array if 10 days apart
I $O(BGPX(0)) Q 1_U_"Tdap"
;now get cpts
S ED=9999999-EDATE-1,BD=9999999-$$DOB^AUPNPAT(P),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=90715 S BGPVARI(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=90715 S BGPVARI(9999999-$P(ED,"."))=""
I $D(BGPVARI) Q 1_U_"Tdap"
F BGPZ=115 S X=$$ANCONT^BGP4D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra Tdap"
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=115 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Tdap",1:"Ref Tdap")
F BGPIMM=90715 D
.S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Tdap",1:"Ref Tdap")
;now check Refusals in imm pkg
;F BGPIMM=115 S R=$$IMMREF^BGP4D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q 3_U_"Ref imm pkg Tdap"
TD ;
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPVARI
;get all immunizations
S C="9^113^138^139"
D GETIMMS^BGP4D32(P,EDATE,C,.BGPX)
;go through and set into array if 10 days apart
I $O(BGPX(0)) Q 1_U_"Td"
;now get cpts
S ED=9999999-EDATE-1,BD=9999999-$$DOB^AUPNPAT(P),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=Y=90714!(Y=90718) S BGPVARI(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=Y=90714!(Y=90718) S BGPVARI(9999999-$P(ED,"."))=""
I $D(BGPVARI) Q 1_U_"Td"
K BGPG S %=P_"^ALL DX [BGP TD IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_"Td"
F BGPZ=9,113,138,139 S X=$$ANCONT^BGP4D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra Td"
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=9,113,138,139 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Td",1:"Ref Td")
;now check Refusals in imm pkg
;F BGPIMM=9,113 S R=$$IMMREF^BGP4D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q 3_U_"Ref imm pkg Td"
Q ""
BGP4D86 ; IHS/CMI/LAB - measure C 06 Nov 2009 2:26 PM ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
IRAR ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
+2 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+3 ;must be 16 or older
IF BGPAGEB<16
SET BGPSTOP=1
QUIT
+4 ;no OSTEOARTHRITIS
IF '$$RHEUAR^BGP4D862(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+5 SET BGPV=$$MEDSPRE^BGP4D863(DFN,BGPBDATE,BGPEDATE)
+6 ;no meds prescribed per logic
IF '$PIECE(BGPV,U)
SET BGPSTOP=1
KILL ^TMP($JOB,"A"),BGPMEDS1
QUIT
+7 SET BGPN1=0
+8 IF BGPACTCL
SET BGPD1=1
+9 IF BGPACTUP
SET BGPD2=1
+10 IF 'BGPD1
SET BGPSTOP=1
QUIT
+11 KILL BGPIRZ,BGPIRV
+12 IF $PIECE(BGPV,U,2)
Begin DoDot:1
+13 SET BGPCBC=$$CBC^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+14 SET BGPLFT=$$LFT^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+15 SET BGPCREAT=$$CREAT^BGP4D22(DFN,BGPBDATE,BGPEDATE)
+16 SET BGPIRZ("A")=0
SET BGPIRV("A")="NSAID: "
+17 ;,BGPIRV("A")=BGPIRV("A")_$$DATE^BGP4UTL($P(BGPCREAT,U,2))_" CREAT, "_$$DATE^BGP4UTL($P(BGPCBC,U,2))_" CBC, "_$$DATE^BGP4UTL($P(BGPLFT,U,2))_" LFT" ;NA MEDS AND HAS CBC,LFT
IF BGPCBC
IF BGPLFT
IF BGPCREAT
SET BGPIRZ("A")=1
+18 IF BGPCREAT
SET BGPIRV("A")=BGPIRV("A")_$$DATE^BGP4UTL($PIECE(BGPCREAT,U,2))_" CREAT"
+19 IF BGPCBC
SET BGPIRV("A")=BGPIRV("A")_$SELECT(BGPIRV("A")]"":", ",1:"")
SET BGPIRV("A")=BGPIRV("A")_$$DATE^BGP4UTL($PIECE(BGPCBC,U,2))_" CBC"
+20 IF BGPLFT
SET BGPIRV("A")=BGPIRV("A")_$SELECT(BGPIRV("A")]"":", ",1:"")
SET BGPIRV("A")=BGPIRV("A")_$$DATE^BGP4UTL($PIECE(BGPLFT,U,2))_" LFT"
End DoDot:1
+21 IF $PIECE(BGPV,U,3)
Begin DoDot:1
+22 SET BGPGOLD=$$GOLDLAB^BGP4D864(DFN,BGPBDATE,BGPEDATE)
+23 SET BGPIRZ("B")=0
SET BGPIRV("B")="IM Gold: "
+24 IF BGPGOLD
SET BGPIRZ("B")=1
SET BGPIRV("B")=BGPIRV("B")_" "_$PIECE(BGPGOLD,U,2)
+25 IF 'BGPGOLD
SET BGPIRV("B")=$PIECE(BGPGOLD,U,2)
End DoDot:1
+26 IF $PIECE(BGPV,U,4)
Begin DoDot:1
+27 SET BGPCBC=$$CBC4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+28 SET BGPIRZ("C")=0
SET BGPIRV("C")="AZATHIOPRINE: "
+29 IF BGPCBC
SET BGPIRZ("C")=1
SET BGPIRV("C")=BGPIRV("C")_"has 4 CBC's"
+30 IF 'BGPCBC
SET BGPIRV("C")=BGPIRV("C")_" does not have 4 CBC's"
End DoDot:1
+31 IF $PIECE(BGPV,U,5)
Begin DoDot:1
+32 SET BGPCBC=$$CBC6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+33 SET BGPIRZ("D")=0
SET BGPIRV("D")="Leflunomide: "
+34 IF BGPCBC
SET BGPIRV("D")=BGPIRV("D")_"has 6 CBC's"
+35 IF 'BGPCBC
SET BGPIRV("D")=BGPIRV("D")_" does not have 6 CBC's"
+36 SET BGPSERUM=$$SERUM6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+37 IF BGPSERUM
SET BGPIRV("D")=BGPIRV("D")_" has 6 Serum Creatinine's"
+38 IF 'BGPSERUM
SET BGPIRV("D")=BGPIRV("D")_" does not have 6 Serum Creatinine's"
+39 SET BGPLFT=$$LFT6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+40 IF BGPLFT
SET BGPIRV("D")=BGPIRV("D")_" has 6 LFT's"
+41 IF 'BGPLFT
SET BGPIRV("D")=BGPIRV("D")_" does not have 6 LFT's"
+42 IF BGPCBC
IF BGPSERUM
IF BGPLFT
SET BGPIRZ("D")=1
End DoDot:1
+43 IF $PIECE(BGPV,U,6)
Begin DoDot:1
+44 SET BGPCBC=$$CBC6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+45 SET BGPIRZ("E")=0
SET BGPIRV("E")="Methotrexate: "
+46 IF BGPCBC
SET BGPIRV("E")=BGPIRV("E")_"has 6 CBC's"
+47 IF 'BGPCBC
SET BGPIRV("E")=BGPIRV("E")_" does not have 6 CBC's"
+48 SET BGPSERUM=$$SERUM6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+49 IF BGPSERUM
SET BGPIRV("E")=BGPIRV("E")_" has 6 Serum Creatinine's"
+50 IF 'BGPSERUM
SET BGPIRV("E")=BGPIRV("E")_" does not have 6 Serum Creatinine's"
+51 SET BGPLFT=$$LFT6^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+52 IF BGPLFT
SET BGPIRV("E")=BGPIRV("E")_" has 6 LFT's"
+53 IF 'BGPLFT
SET BGPIRV("E")=BGPIRV("E")_" does not have 6 LFT's"
+54 IF BGPCBC
IF BGPSERUM
IF BGPLFT
SET BGPIRZ("E")=1
End DoDot:1
+55 IF $PIECE(BGPV,U,7)
Begin DoDot:1
+56 SET BGPCBC=$$CBC^BGP4D861(DFN,$$FMADD^XLFDT(BGPEDATE,-180),BGPEDATE)
+57 SET BGPIRZ("F")=0
SET BGPIRV("F")="Cycolsporin: "
+58 IF BGPCBC
SET BGPIRV("F")=BGPIRV("F")_"has CBC Past 180 days"
+59 IF 'BGPCBC
SET BGPIRV("F")=BGPIRV("F")_" does not have CBC past 180 days"
+60 SET BGPLFT=$$LFT^BGP4D861(DFN,$$FMADD^XLFDT(BGPBDATE,-180),BGPEDATE)
+61 IF BGPLFT
SET BGPIRV("F")=BGPIRV("F")_" has LFT past 180 days"
+62 IF 'BGPLFT
SET BGPIRV("F")=BGPIRV("F")_" does not have LFT 180 days"
+63 SET BGPPOT=$$POT^BGP4D861(DFN,$$FMADD^XLFDT(BGPBDATE,-180),BGPEDATE)
+64 IF BGPPOT
SET BGPIRV("F")=BGPIRV("F")_" has Potassium in 180 days"
+65 IF 'BGPPOT
SET BGPIRV("F")=BGPIRV("F")_" does not have Potassium"
+66 SET BGPSERUM=$$SERUM12^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+67 IF BGPSERUM
SET BGPIRV("F")=BGPIRV("F")_" has 12 serum creatinine"
+68 IF 'BGPSERUM
SET BGPIRV("F")=BGPIRV("F")_" does not have 12 serum creatinine"
+69 IF BGPCBC
IF BGPSERUM
IF BGPLFT
IF BGPPOT
SET BGPIRZ("F")=1
End DoDot:1
+70 IF $PIECE(BGPV,U,8)
Begin DoDot:1
+71 SET BGPCBC=$$CBC4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+72 SET BGPIRZ("G")=0
SET BGPIRV("G")="Oral Gold: "
+73 IF BGPCBC
SET BGPIRV("G")=BGPIRV("G")_"has 4 CBC's"
+74 IF 'BGPCBC
SET BGPIRV("G")=BGPIRV("G")_" does not have 6 CBC's"
+75 SET BGPUP=$$UP4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+76 IF BGPUP
SET BGPIRV("G")=BGPIRV("G")_" has 4 Urine Proteins"
+77 IF 'BGPUP
SET BGPIRV("G")=BGPIRV("G")_" does not have 4 Urine Protein's"
+78 IF BGPCBC
IF BGPUP
SET BGPIRZ("G")=1
End DoDot:1
+79 IF $PIECE(BGPV,U,9)
Begin DoDot:1
+80 SET BGPCBC=$$CBC^BGP4D861(DFN,$$FMADD^XLFDT(BGPEDATE,-180),BGPEDATE)
+81 SET BGPIRZ("H")=0
SET BGPIRV("H")="Mycophenolate: "
+82 IF BGPCBC
SET BGPIRV("H")=BGPIRV("H")_"has CBC Past 180 days"
+83 IF 'BGPCBC
SET BGPIRV("H")=BGPIRV("H")_" does not have CBC past 180 days"
+84 IF BGPCBC
SET BGPIRZ("H")=1
End DoDot:1
+85 IF $PIECE(BGPV,U,10)
Begin DoDot:1
+86 SET BGPCBC=$$CBC4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+87 SET BGPIRZ("I")=0
SET BGPIRV("I")="Penicillamine: "
+88 IF BGPCBC
SET BGPIRV("I")=BGPIRV("I")_"has 4 CBC's"
+89 IF 'BGPCBC
SET BGPIRV("I")=BGPIRV("I")_" does not have 6 CBC's"
+90 SET BGPUP=$$UP4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+91 IF BGPUP
SET BGPIRV("I")=BGPIRV("I")_" has 4 Urine Proteins"
+92 IF 'BGPUP
SET BGPIRV("I")=BGPIRV("I")_" does not have 4 Urine Protein's"
+93 IF BGPCBC
IF BGPUP
SET BGPIRZ("I")=1
End DoDot:1
+94 IF $PIECE(BGPV,U,11)
Begin DoDot:1
+95 SET BGPCBC=$$CBC4^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+96 SET BGPIRZ("J")=0
SET BGPIRV("J")="Sulfasalazine: "
+97 IF BGPCBC
SET BGPIRZ("J")=1
SET BGPIRV("J")=BGPIRV("J")_"has 4 CBC's"
+98 IF 'BGPCBC
SET BGPIRV("J")=BGPIRV("J")_" does not have 4 CBC's"
End DoDot:1
+99 IF $PIECE(BGPV,U,12)
Begin DoDot:1
+100 SET BGPGLU=$$GLUCOSE^BGP4D861(DFN,BGPBDATE,BGPEDATE)
+101 SET BGPIRZ("K")=0
SET BGPIRV("K")="Glucocorticoids: "
+102 IF BGPGLU
SET BGPIRZ("K")=1
SET BGPIRV("K")=BGPIRV("K")_$$DATE^BGP4UTL($PIECE(BGPGLU,U,2))_" Glucose"
+103 IF 'BGPGLU
SET BGPIRV("K")=BGPIRV("K")_" does not have Glucose"
End DoDot:1
+104 SET BGPN1=1
SET X=""
FOR
SET X=$ORDER(BGPIRZ(X))
IF X=""
QUIT
IF BGPIRZ(X)=0
SET BGPN1=0
+105 SET BGPVALUE=$SELECT(BGPD1:"AC",1:"")_"|||"
+106 SET BGPVALUE=BGPVALUE_$SELECT(BGPN1:"YES: ",1:"NO: ")
SET X=""
FOR
SET X=$ORDER(BGPIRV(X))
IF X=""
QUIT
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,U,2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_BGPIRV(X)
+107 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+108 KILL ^TMP($JOB,"A")
+109 QUIT
+110 ;
TDAP(P,EDATE) ;EP
+1 KILL BGPC,BGPG,BGPX
+2 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+3 KILL BGPVARI
+4 ;get all immunizations
+5 SET C="115"
+6 DO GETIMMS^BGP4D32(P,EDATE,C,.BGPX)
+7 ;go through and set into array if 10 days apart
+8 IF $ORDER(BGPX(0))
QUIT 1_U_"Tdap"
+9 ;now get cpts
+10 SET ED=9999999-EDATE-1
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+11 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+12 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90715
SET BGPVARI(9999999-$PIECE(ED,"."))=""
End DoDot:3
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90715
SET BGPVARI(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF $DATA(BGPVARI)
QUIT 1_U_"Tdap"
+19 FOR BGPZ=115
SET X=$$ANCONT^BGP4D31(P,BGPZ,EDATE)
IF X]""
QUIT
+20 IF X]""
QUIT 4_U_"Contra Tdap"
+21 ;now go to Refusals
+22 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+23 FOR BGPIMM=115
Begin DoDot:1
+24 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+25 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+26 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Tdap",1:"Ref Tdap")
+27 FOR BGPIMM=90715
Begin DoDot:1
+28 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+29 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+30 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Tdap",1:"Ref Tdap")
+31 ;now check Refusals in imm pkg
+32 ;F BGPIMM=115 S R=$$IMMREF^BGP4D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+33 ;I R Q 3_U_"Ref imm pkg Tdap"
TD ;
+1 KILL BGPC,BGPG,BGPX
+2 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+3 KILL BGPVARI
+4 ;get all immunizations
+5 SET C="9^113^138^139"
+6 DO GETIMMS^BGP4D32(P,EDATE,C,.BGPX)
+7 ;go through and set into array if 10 days apart
+8 IF $ORDER(BGPX(0))
QUIT 1_U_"Td"
+9 ;now get cpts
+10 SET ED=9999999-EDATE-1
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+11 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+12 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=Y=90714!(Y=90718)
SET BGPVARI(9999999-$PIECE(ED,"."))=""
End DoDot:3
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=Y=90714!(Y=90718)
SET BGPVARI(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF $DATA(BGPVARI)
QUIT 1_U_"Td"
+19 KILL BGPG
SET %=P_"^ALL DX [BGP TD IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+20 IF $DATA(BGPG(1))
QUIT 1_U_"Td"
+21 FOR BGPZ=9,113,138,139
SET X=$$ANCONT^BGP4D31(P,BGPZ,EDATE)
IF X]""
QUIT
+22 IF X]""
QUIT 4_U_"Contra Td"
+23 ;now go to Refusals
+24 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+25 FOR BGPIMM=9,113,138,139
Begin DoDot:1
+26 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+27 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+28 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Td",1:"Ref Td")
+29 ;now check Refusals in imm pkg
+30 ;F BGPIMM=9,113 S R=$$IMMREF^BGP4D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+31 ;I R Q 3_U_"Ref imm pkg Td"
+32 QUIT ""
