BGP2D84 ; IHS/CMI/LAB - measure C ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
HEDURI ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
I 'BGPACTUP S BGPSTOP=1 Q
S A=$$FMDIFF^XLFDT($$FMADD^XLFDT(BGPBDATE,-182),$P(^DPT(DFN,0),U,3))
I A<91 S BGPSTOP=1 Q ;less than 3 months old
;S A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,-180))
;I A<2 S BGPSTOP=1 ;must be at least 2
S A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,182))
I A>18 S BGPSTOP=1 Q ;must not be older than 18 on this date
S BGPDN=$$URI(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182)) I 'BGPDN S BGPSTOP=1 Q ;no URI DX
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
S BGPN=$$CANTI(DFN,BGPDN,$$FMADD^XLFDT(BGPDN,3))
S BGPN1=$S('$P(BGPN,U):1,1:0)
S BGPVALUE=$S(BGPRTYPE'=3:"UP",1:"")_$S(BGPD1:",AC",1:"")_"|||"_$P(BGPN,U,2)_" "_$P(BGPN,U,3)_$S(BGPN1:" MEETS MEASURE",1:"DOES NOT MEET MEASURE")
K A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z,BDATE,EDATE,BGPDN,BGPN,BGPG,BGPC
K ^TMP($J,"A")
Q
;
URI(P,BDATE,EDATE) ;
NEW BGPG,Y,X,G,V,E,C,H
S Y="BGPG("
S X=P_"^ALL DX [BGP URI DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) Q 0
S X=0,G=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S V=$P(BGPG(X),U,5)
.Q:'$D(^AUPNVSIT(V,0))
.I "ASO"'[$P(^AUPNVSIT(V,0),U,7) Q ;not outpatient
.S (C,E)=0 F S E=$O(^AUPNVPOV("AD",V,E)) Q:E'=+E S C=C+1
.Q:C>1 ;can't have any other diagnoses
.I $$CLINIC^APCLV(V,"C")=30 D Q:H ;if H is 1 then there was a hosp stay so don't use this visit
..S H=0
..S E=$O(^AUPNVER("AD",V,0)) I E,"ATLM"[$P($G(^AUPNVER(E,0)),U,11) S H=1 Q ;er visit with admission
..S H=$$HOSPURI(P,$P($P(^AUPNVSIT(V,0),U),"."))
.;NOW CHECK FOR ITEM #4 - NO NEW OR REFILL OF ANTIBIOTICS 30 DAYS PRIOR
.S BGPD=$P($P(^AUPNVSIT(V,0),U),".")
.Q:$$NEWRFA(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,-1))
.Q:$$ACTA(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,-1))
.;Q:'$$CANTI(P,BGPD,$$FMADD^XLFDT(BGPD,3))
.S G=BGPD
.Q
Q G
NDC(A,B) ;
;a is drug ien
;b is taxonomy ien
NEW BGPNDC
S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)
I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
Q 0
NEWRFA(P,BDATE,EDATE) ;
K ^TMP($J,"A")
NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
K BGPMEDS1
D GETMEDS^BGP2UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) G NEWFRAP
S T1=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
S T4=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
S (X,G,M,E)=0,D="" F S X=$O(BGPMEDS1(X)) Q:X'=+X!(D) S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
.Q:'$D(^AUPNVSIT(V,0))
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)),$P(^AUPNVMED(Y,0),U,8)="" S D=1
K ^TMP($J,"A")
I D Q D
NEWFRAP ;check V PROCEDURE
S D=$$LASTPRC^BGP2UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
Q $P(D,U)
CANTI(P,BDATE,EDATE) ;
K ^TMP($J,"A")
NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
K BGPMEDS1
D GETMEDS^BGP2UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) G CANTIP
S T1=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
S T4=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
S (X,G,M,E)=0,D="" F S X=$O(BGPMEDS1(X)) Q:X'=+X!(D) S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
.Q:'$D(^AUPNVSIT(V,0))
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)) S D=1_U_"antibiotic: "_$$DATE^BGP2UTL($P($P(^AUPNVSIT(V,0),U),"."))
K ^TMP($J,"A")
I D Q D
CANTIP ;check V PROCEDURE
S D=$$LASTPRC^BGP2UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
Q $P(D,U)_$S(D:"^antibiotic injection: "_$$DATE^BGP2UTL($P(D,U,3)),1:"")
ACTA(P,BDATE,EDATE) ;
K ^TMP($J,"A")
NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
K BGPMEDS1
D GETMEDS^BGP2UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) G ACTAP
S T1=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
S T4=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
S (X,G,M,E)=0,D="" F S X=$O(BGPMEDS1(X)) Q:X'=+X!(D) S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
.Q:'$D(^AUPNVSIT(V,0))
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.S B=$$FMDIFF^XLFDT(EDATE,$P($P(^AUPNVSIT(V,0),U),"."))
.I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)),$P(^AUPNVMED(Y,0),U,8)="" I $P(^AUPNVMED(Y,0),U,6)'<B S D=1
K ^TMP($J,"A")
I D Q D
ACTAP ;check V PROCEDURE
S D=$$LASTPRC^BGP2UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",$$FMADD^XLFDT(EDATE,-30),$$FMADD^XLFDT(EDATE,-1))
Q $P(D,U)_$S(D:"^antibiotic injection: "_$$DATE^BGP2UTL($P(D,U,3)),1:"")
HOSPURI(P,D) ;is there a hosp with pharyngitis on date D or 1 day later
S (I,J,K,Q)=0
F S I=$O(^AUPNVSIT("AAH",P,I)) Q:I'=+I D
.S J=0 F S J=$O(^AUPNVSIT("AAH",P,I,J)) Q:J'=+J D
..Q:'$D(^AUPNVSIT(J,0))
..S K=$P($P(^AUPNVSIT(J,0),U),".")
..I K<D Q ;before outpatient visit
..I K>$$FMADD^XLFDT(D,1) Q ;more than 1 day after outpatient visit date
..;now must have a pharyngitis dx
..S (R,S,T)=0
..F S R=$O(^AUPNVPOV("AD",J,R)) Q:R'=+R D
...S T=$P($G(^AUPNVPOV(R,0)),U)
...Q:T=""
...S T=$P($$ICDDX^ICDCODE(T),U,2)
...Q:T=""
...Q:'$$ICD^ATXCHK(T,$O(^ATXAX("B","BGP URI DXS",0)),9)
...S S=1
..Q:'S
..S Q=1
.Q
Q Q
STREP(P,BDATE,EDATE) ;EP
K BGPC
S BGPC=0
S %=$$CPT^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)))
I %]"" Q 1_U_%
S %=$$TRAN^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)))
I %]"" Q 1_U_%
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP GROUP A STREP LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP GROUP A STREP TESTS",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP2D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
I BGPC Q BGPC
;now check v microbiology
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVMIC("AE",P,D)) Q:D'=+D!(D>B)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVMIC("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVMIC("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVMIC(X,0))
...I BGPLT,$P(^AUPNVMIC(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVMIC(X,0),U))) S BGPC=1_U_(9999999-D)_U_"MICRO" Q
...Q:'T
...S J=$P($G(^AUPNVMIC(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP2D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"MICRO LOINC"
...Q
Q BGPC
HEPC ;
S (BGPN1,BGPD1)=0
NEW BGPHSCR
I 'BGPACTUP S BGPSTOP=1 Q
Q:$$DOB^AUPNPAT(DFN)<2450101
Q:$$DOB^AUPNPAT(DFN)>2651231
Q:$$HEPCDX(DFN,BGPEDATE)
S BGPD1=1
S BGPHSCR=$$HEPCSCR(DFN,BGPEDATE)
I $P(BGPHSCR,U,1) S BGPN1=1
S BGPVALUE=""
S BGPVALUE="UP|||"_$P(BGPHSCR,U,2)
Q
HEPCDX(P,EDATE) ;
NEW T,X,G
;now check problem list
S T=$O(^ATXAX("B","BGP HEPATITIS C DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after end of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=1
.Q
I G Q G
S X=$$LASTDX^BGP2UTL1(P,"BGP HEPATITIS C DXS")
I X Q 1
Q ""
HEPCSCR(P,EDATE) ;
NEW X,G,T,%,BGPC,BGPLT,L,D,J
S %="",E=+$$CODEN^ICPTCOD(86803),%=$$CPTI^BGP2DU(P,$$DOB^AUPNPAT(P),EDATE,E)
I % Q 1_U_$$DATE^BGP2UTL($P(%,U,2))_" CPT 86803"
;now get all loinc/taxonomy tests
S BGPC=""
S T=$O(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP HEP C TESTS TAX",0))
S E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(BGPC) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_$$DATE^BGP2UTL((9999999-D))_" Lab Test" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP2D2(J,T)
...S BGPC=1_U_$$DATE^BGP2UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_")"
...Q
Q BGPC
CD4RES(P,BDATE,EDATE,NORES) ;EP
NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
K BGPG,BGPT,BGPC
S BGPC=0
S NORES=$G(NORES)
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP CD4 LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP CD4 TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP2D2(J,T)
...S R=$P(^AUPNVLAB(X,0),U,4)
...I 'R S R=""
...S BGPC=BGPC+1,BGPT(D,BGPC)=R
...Q
; now got though and set return value of done 1 or 0^VALUE^date
S D=0,G="" F S D=$O(BGPT(D)) Q:D'=+D!(G]"") D
.S C=0 F S C=$O(BGPT(D,C)) Q:C'=+C!(G]"") D
..S X=BGPT(D,C)
..I X="" Q
..S G=(9999999-D)_U_X
..Q
I G="" D ;now get one with no result
.S D=0,G="" F S D=$O(BGPT(D)) Q:D'=+D!(G]"") D
..S C=0 F S C=$O(BGPT(D,C)) Q:C'=+C!(G]"") D
...S X=BGPT(D,C)
...I X="" Q
...S G=(9999999-D)_U_X
..Q
;
I 'NORES,G]"" Q 1_U_G ;IF WANT A RESULT AND THERE IS ONE QUIT
S %=$$CPT^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CD4 CPTS",0)),5)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
S %=$$TRAN^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CD4 CPTS",0)),5)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
I '$O(BGPT(0)) Q ""
S %=$O(BGPT(0)) S C=$O(BGPT(%,0)) Q 1_"^"_(9999999-%)_"^"_BGPT(%,C)
Q ""
;
BGP2D84 ; IHS/CMI/LAB - measure C ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
HEDURI ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
+2 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+3 SET A=$$FMDIFF^XLFDT($$FMADD^XLFDT(BGPBDATE,-182),$PIECE(^DPT(DFN,0),U,3))
+4 ;less than 3 months old
IF A<91
SET BGPSTOP=1
QUIT
+5 ;S A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,-180))
+6 ;I A<2 S BGPSTOP=1 ;must be at least 2
+7 SET A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,182))
+8 ;must not be older than 18 on this date
IF A>18
SET BGPSTOP=1
QUIT
+9 ;no URI DX
SET BGPDN=$$URI(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182))
IF 'BGPDN
SET BGPSTOP=1
QUIT
+10 IF BGPACTCL
SET BGPD1=1
+11 IF BGPACTUP
SET BGPD2=1
+12 SET BGPN=$$CANTI(DFN,BGPDN,$$FMADD^XLFDT(BGPDN,3))
+13 SET BGPN1=$SELECT('$PIECE(BGPN,U):1,1:0)
+14 SET BGPVALUE=$SELECT(BGPRTYPE'=3:"UP",1:"")_$SELECT(BGPD1:",AC",1:"")_"|||"_$PIECE(BGPN,U,2)_" "_$PIECE(BGPN,U,3)_$SELECT(BGPN1:" MEETS MEASURE",1:"DOES NOT MEET MEASURE")
+15 KILL A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z,BDATE,EDATE,BGPDN,BGPN,BGPG,BGPC
+16 KILL ^TMP($JOB,"A")
+17 QUIT
+18 ;
URI(P,BDATE,EDATE) ;
+1 NEW BGPG,Y,X,G,V,E,C,H
+2 SET Y="BGPG("
+3 SET X=P_"^ALL DX [BGP URI DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+4 IF '$DATA(BGPG(1))
QUIT 0
+5 SET X=0
SET G=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+6 SET V=$PIECE(BGPG(X),U,5)
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 ;not outpatient
IF "ASO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+9 SET (C,E)=0
FOR
SET E=$ORDER(^AUPNVPOV("AD",V,E))
IF E'=+E
QUIT
SET C=C+1
+10 ;can't have any other diagnoses
IF C>1
QUIT
+11 ;if H is 1 then there was a hosp stay so don't use this visit
IF $$CLINIC^APCLV(V,"C")=30
Begin DoDot:2
+12 SET H=0
+13 ;er visit with admission
SET E=$ORDER(^AUPNVER("AD",V,0))
IF E
IF "ATLM"[$PIECE($GET(^AUPNVER(E,0)),U,11)
SET H=1
QUIT
+14 SET H=$$HOSPURI(P,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
End DoDot:2
IF H
QUIT
+15 ;NOW CHECK FOR ITEM #4 - NO NEW OR REFILL OF ANTIBIOTICS 30 DAYS PRIOR
+16 SET BGPD=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+17 IF $$NEWRFA(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,-1))
QUIT
+18 IF $$ACTA(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,-1))
QUIT
+19 ;Q:'$$CANTI(P,BGPD,$$FMADD^XLFDT(BGPD,3))
+20 SET G=BGPD
+21 QUIT
End DoDot:1
+22 QUIT G
NDC(A,B) ;
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 NEW BGPNDC
+4 SET BGPNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+5 IF BGPNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BGPNDC))
QUIT 1
+6 QUIT 0
NEWRFA(P,BDATE,EDATE) ;
+1 KILL ^TMP($JOB,"A")
+2 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
+3 KILL BGPMEDS1
+4 DO GETMEDS^BGP2UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
GOTO NEWFRAP
+6 SET T1=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
+7 SET T4=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
+8 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(D)
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+11 IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
IF $PIECE(^AUPNVMED(Y,0),U,8)=""
SET D=1
End DoDot:1
+12 KILL ^TMP($JOB,"A")
+13 IF D
QUIT D
NEWFRAP ;check V PROCEDURE
+1 SET D=$$LASTPRC^BGP2UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
+2 QUIT $PIECE(D,U)
CANTI(P,BDATE,EDATE) ;
+1 KILL ^TMP($JOB,"A")
+2 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
+3 KILL BGPMEDS1
+4 DO GETMEDS^BGP2UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
GOTO CANTIP
+6 SET T1=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
+7 SET T4=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
+8 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(D)
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+11 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+12 IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
SET D=1_U_"antibiotic: "_$$DATE^BGP2UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
End DoDot:1
+13 KILL ^TMP($JOB,"A")
+14 IF D
QUIT D
CANTIP ;check V PROCEDURE
+1 SET D=$$LASTPRC^BGP2UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
+2 QUIT $PIECE(D,U)_$SELECT(D:"^antibiotic injection: "_$$DATE^BGP2UTL($PIECE(D,U,3)),1:"")
ACTA(P,BDATE,EDATE) ;
+1 KILL ^TMP($JOB,"A")
+2 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
+3 KILL BGPMEDS1
+4 DO GETMEDS^BGP2UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
GOTO ACTAP
+6 SET T1=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
+7 SET T4=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
+8 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(D)
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+11 SET B=$$FMDIFF^XLFDT(EDATE,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+12 IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
IF $PIECE(^AUPNVMED(Y,0),U,8)=""
IF $PIECE(^AUPNVMED(Y,0),U,6)'<B
SET D=1
End DoDot:1
+13 KILL ^TMP($JOB,"A")
+14 IF D
QUIT D
ACTAP ;check V PROCEDURE
+1 SET D=$$LASTPRC^BGP2UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",$$FMADD^XLFDT(EDATE,-30),$$FMADD^XLFDT(EDATE,-1))
+2 QUIT $PIECE(D,U)_$SELECT(D:"^antibiotic injection: "_$$DATE^BGP2UTL($PIECE(D,U,3)),1:"")
HOSPURI(P,D) ;is there a hosp with pharyngitis on date D or 1 day later
+1 SET (I,J,K,Q)=0
+2 FOR
SET I=$ORDER(^AUPNVSIT("AAH",P,I))
IF I'=+I
QUIT
Begin DoDot:1
+3 SET J=0
FOR
SET J=$ORDER(^AUPNVSIT("AAH",P,I,J))
IF J'=+J
QUIT
Begin DoDot:2
+4 IF '$DATA(^AUPNVSIT(J,0))
QUIT
+5 SET K=$PIECE($PIECE(^AUPNVSIT(J,0),U),".")
+6 ;before outpatient visit
IF K<D
QUIT
+7 ;more than 1 day after outpatient visit date
IF K>$$FMADD^XLFDT(D,1)
QUIT
+8 ;now must have a pharyngitis dx
+9 SET (R,S,T)=0
+10 FOR
SET R=$ORDER(^AUPNVPOV("AD",J,R))
IF R'=+R
QUIT
Begin DoDot:3
+11 SET T=$PIECE($GET(^AUPNVPOV(R,0)),U)
+12 IF T=""
QUIT
+13 SET T=$PIECE($$ICDDX^ICDCODE(T),U,2)
+14 IF T=""
QUIT
+15 IF '$$ICD^ATXCHK(T,$ORDER(^ATXAX("B","BGP URI DXS",0)),9)
QUIT
+16 SET S=1
End DoDot:3
+17 IF 'S
QUIT
+18 SET Q=1
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT Q
STREP(P,BDATE,EDATE) ;EP
+1 KILL BGPC
+2 SET BGPC=0
+3 SET %=$$CPT^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP GROUP A STREP CPT",0)))
+4 IF %]""
QUIT 1_U_%
+5 SET %=$$TRAN^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP GROUP A STREP CPT",0)))
+6 IF %]""
QUIT 1_U_%
+7 ;now get all loinc/taxonomy tests
+8 SET T=$ORDER(^ATXAX("B","BGP GROUP A STREP LOINC",0))
+9 SET BGPLT=$ORDER(^ATXLAB("B","BGP GROUP A STREP TESTS",0))
+10 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+11 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+13 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+14 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+15 IF 'T
QUIT
+16 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+17 IF '$$LOINC^BGP2D21(J,T)
QUIT
+18 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+19 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+20 IF BGPC
QUIT BGPC
+21 ;now check v microbiology
+22 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVMIC("AE",P,D))
IF D'=+D!(D>B)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+23 SET L=0
FOR
SET L=$ORDER(^AUPNVMIC("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+24 SET X=0
FOR
SET X=$ORDER(^AUPNVMIC("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+25 IF '$DATA(^AUPNVMIC(X,0))
QUIT
+26 IF BGPLT
IF $PIECE(^AUPNVMIC(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVMIC(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"MICRO"
QUIT
+27 IF 'T
QUIT
+28 SET J=$PIECE($GET(^AUPNVMIC(X,11)),U,13)
IF J=""
QUIT
+29 IF '$$LOINC^BGP2D21(J,T)
QUIT
+30 SET BGPC=1_U_(9999999-D)_U_"MICRO LOINC"
+31 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT BGPC
HEPC ;
+1 SET (BGPN1,BGPD1)=0
+2 NEW BGPHSCR
+3 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+4 IF $$DOB^AUPNPAT(DFN)<2450101
QUIT
+5 IF $$DOB^AUPNPAT(DFN)>2651231
QUIT
+6 IF $$HEPCDX(DFN,BGPEDATE)
QUIT
+7 SET BGPD1=1
+8 SET BGPHSCR=$$HEPCSCR(DFN,BGPEDATE)
+9 IF $PIECE(BGPHSCR,U,1)
SET BGPN1=1
+10 SET BGPVALUE=""
+11 SET BGPVALUE="UP|||"_$PIECE(BGPHSCR,U,2)
+12 QUIT
HEPCDX(P,EDATE) ;
+1 NEW T,X,G
+2 ;now check problem list
+3 SET T=$ORDER(^ATXAX("B","BGP HEPATITIS C DXS",0))
+4 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+5 ;if added to pl after end of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+6 SET Y=$PIECE(^AUPNPROB(X,0),U)
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+9 SET G=1
+10 QUIT
End DoDot:1
+11 IF G
QUIT G
+12 SET X=$$LASTDX^BGP2UTL1(P,"BGP HEPATITIS C DXS")
+13 IF X
QUIT 1
+14 QUIT ""
HEPCSCR(P,EDATE) ;
+1 NEW X,G,T,%,BGPC,BGPLT,L,D,J
+2 SET %=""
SET E=+$$CODEN^ICPTCOD(86803)
SET %=$$CPTI^BGP2DU(P,$$DOB^AUPNPAT(P),EDATE,E)
+3 IF %
QUIT 1_U_$$DATE^BGP2UTL($PIECE(%,U,2))_" CPT 86803"
+4 ;now get all loinc/taxonomy tests
+5 SET BGPC=""
+6 SET T=$ORDER(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
+7 SET BGPLT=$ORDER(^ATXLAB("B","BGP HEP C TESTS TAX",0))
+8 SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(BGPC)
QUIT
Begin DoDot:1
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_$$DATE^BGP2UTL((9999999-D))_" Lab Test"
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC^BGP2D2(J,T)
QUIT
+16 SET BGPC=1_U_$$DATE^BGP2UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_")"
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT BGPC
CD4RES(P,BDATE,EDATE,NORES) ;EP
+1 NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
+2 KILL BGPG,BGPT,BGPC
+3 SET BGPC=0
+4 SET NORES=$GET(NORES)
+5 ;now get all loinc/taxonomy tests
+6 SET T=$ORDER(^ATXAX("B","BGP CD4 LOINC CODES",0))
+7 SET BGPLT=$ORDER(^ATXLAB("B","BGP CD4 TAX",0))
+8 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPT(D,BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC^BGP2D2(J,T)
QUIT
+16 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+17 IF 'R
SET R=""
+18 SET BGPC=BGPC+1
SET BGPT(D,BGPC)=R
+19 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+20 ; now got though and set return value of done 1 or 0^VALUE^date
+21 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+22 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+23 SET X=BGPT(D,C)
+24 IF X=""
QUIT
+25 SET G=(9999999-D)_U_X
+26 QUIT
End DoDot:2
End DoDot:1
+27 ;now get one with no result
IF G=""
Begin DoDot:1
+28 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:2
+29 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:3
+30 SET X=BGPT(D,C)
+31 IF X=""
QUIT
+32 SET G=(9999999-D)_U_X
End DoDot:3
+33 QUIT
End DoDot:2
End DoDot:1
+34 ;
+35 ;IF WANT A RESULT AND THERE IS ONE QUIT
IF 'NORES
IF G]""
QUIT 1_U_G
+36 SET %=$$CPT^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CD4 CPTS",0)),5)
+37 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,1),BGPC)="CPT "_$PIECE(%,U,2)
+38 SET %=$$TRAN^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CD4 CPTS",0)),5)
+39 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,1),BGPC)="CPT "_$PIECE(%,U,2)
+40 IF '$ORDER(BGPT(0))
QUIT ""
+41 SET %=$ORDER(BGPT(0))
SET C=$ORDER(BGPT(%,0))
QUIT 1_"^"_(9999999-%)_"^"_BGPT(%,C)
+42 QUIT ""
+43 ;
