BGP8D83 ; IHS/CMI/LAB - measure C 07 Jan 2018 11:45 AM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
IHEDCWP ;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=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,-182))
I A<3 S BGPSTOP=1 Q ;must be at least 3
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=$$PHAR(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182)) I 'BGPDN S BGPSTOP=1 Q ;no PHARYNGITIS DX
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
S BGPN=$$STREP(DFN,$$FMADD^XLFDT(BGPDN,-3),$$FMADD^XLFDT(BGPDN,3))
S BGPN1=+BGPN
S BGPVALUE=$S(BGPRTYPE=3:"",1:"UP")_$S(BGPD1:",AC",1:"")_"|||"_$$DATE^BGP8UTL($P(BGPN,U,2))_" "_$P(BGPN,U,3)
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"),BGPMEDS1
Q
;
PHAR(P,BDATE,EDATE) ;
NEW BGPG,Y,E,X,Y,G,V,C,H,BGPD
S Y="BGPG("
S X=P_"^ALL DX [BGP PHARYNGITIS 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 Y=$P($G(^AUPNVPOV(E,0)),U) I Y,'$$ICD^BGP8UTL2(Y,$O(^ATXAX("B","BGP PHARYNGITIS DXS",9))) S C=C+1
.Q:C ;HAS ANOTHER DX OTHER THAN A URI DX ;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=$$HOSPPHAR(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,-1))
.Q:'$$CANTI(P,BGPD,$$FMADD^XLFDT(BGPD,3))
.S G=BGPD
.Q
K BGPMEDS1
Q G
NDC(A,B) ;
;a is drug ien
;b is taxonomy ien
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^BGP8UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) G NEWP
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))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)) S D=1
K ^TMP($J,"A"),BGPMEDS1
I D Q D
NEWP ;check V PROCEDURE
S D=$$LASTPRC^BGP8UTL1(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^BGP8UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) G CANP
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))
.Q:'$D(^AUPNVMED(Y))
.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
K ^TMP($J,"A"),BGPMEDS1
I D Q D
CANP ;check V PROCEDURE
S D=$$LASTPRC^BGP8UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
Q $P(D,U)
ACTA(P,EDATE) ;
K ^TMP($J,"A")
NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
K BGPMEDS1
D GETMEDS^BGP8UTL2(P,$$FMADD^XLFDT(EDATE,-365),EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) Q 0
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))
.Q:'$D(^AUPNVMED(Y))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.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)) I $P(^AUPNVMED(Y,0),U,7)'<B S D=1
K ^TMP($J,"A"),BGPMEDS1
Q D
HOSPPHAR(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^BGP8UTL2(T),U,2)
...Q:T=""
...Q:'$$ICD^BGP8UTL2(T,$O(^ATXAX("B","BGP PHARYNGITIS 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^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)),5)
I %]"" S $P(%,U,2)="CPT "_$P(%,U,2) Q 1_U_%
S %=$$TRAN^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)),5)
I %]"" S $P(%,U,2)="CPT "_$P(%,U,2) 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_$P(^LAB(60,$P(^AUPNVLAB(X,0),U),0),U) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=1_U_(9999999-D)_U_$P(^LAB(60,$P(^AUPNVLAB(X,0),U),0),U)
...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_$P(^LAB(60,$P(^AUPNVMIC(X,0),U),0),U) Q
...Q:'T
...S J=$P($G(^AUPNVMIC(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=1_U_(9999999-D)_U_$P(^LAB(60,$P(^AUPNVMIC(X,0),U),0),U)
...Q
Q BGPC
BGP8D83 ; IHS/CMI/LAB - measure C 07 Jan 2018 11:45 AM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
IHEDCWP ;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=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,-182))
+4 ;must be at least 3
IF A<3
SET BGPSTOP=1
QUIT
+5 SET A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,182))
+6 ;must not be older than 18 on this date
IF A>18
SET BGPSTOP=1
QUIT
+7 ;no PHARYNGITIS DX
SET BGPDN=$$PHAR(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182))
IF 'BGPDN
SET BGPSTOP=1
QUIT
+8 IF BGPACTCL
SET BGPD1=1
+9 IF BGPACTUP
SET BGPD2=1
+10 SET BGPN=$$STREP(DFN,$$FMADD^XLFDT(BGPDN,-3),$$FMADD^XLFDT(BGPDN,3))
+11 SET BGPN1=+BGPN
+12 SET BGPVALUE=$SELECT(BGPRTYPE=3:"",1:"UP")_$SELECT(BGPD1:",AC",1:"")_"|||"_$$DATE^BGP8UTL($PIECE(BGPN,U,2))_" "_$PIECE(BGPN,U,3)
+13 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
+14 KILL ^TMP($JOB,"A"),BGPMEDS1
+15 QUIT
+16 ;
PHAR(P,BDATE,EDATE) ;
+1 NEW BGPG,Y,E,X,Y,G,V,C,H,BGPD
+2 SET Y="BGPG("
+3 SET X=P_"^ALL DX [BGP PHARYNGITIS 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 Y=$PIECE($GET(^AUPNVPOV(E,0)),U)
IF Y
IF '$$ICD^BGP8UTL2(Y,$ORDER(^ATXAX("B","BGP PHARYNGITIS DXS",9)))
SET C=C+1
+10 ;HAS ANOTHER DX OTHER THAN A URI DX ;can't have any other diagnoses
IF C
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=$$HOSPPHAR(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,-1))
QUIT
+19 IF '$$CANTI(P,BGPD,$$FMADD^XLFDT(BGPD,3))
QUIT
+20 SET G=BGPD
+21 QUIT
End DoDot:1
+22 KILL BGPMEDS1
+23 QUIT G
NDC(A,B) ;
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 SET BGPNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+4 IF BGPNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BGPNDC))
QUIT 1
+5 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^BGP8UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
GOTO NEWP
+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 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+11 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+12 IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
SET D=1
End DoDot:1
+13 KILL ^TMP($JOB,"A"),BGPMEDS1
+14 IF D
QUIT D
NEWP ;check V PROCEDURE
+1 SET D=$$LASTPRC^BGP8UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
+2 QUIT $PIECE(D,U)
+3 ;
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^BGP8UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
GOTO CANP
+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 IF '$DATA(^AUPNVMED(Y))
QUIT
+11 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+12 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+13 IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
SET D=1
End DoDot:1
+14 KILL ^TMP($JOB,"A"),BGPMEDS1
+15 IF D
QUIT D
CANP ;check V PROCEDURE
+1 SET D=$$LASTPRC^BGP8UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
+2 QUIT $PIECE(D,U)
ACTA(P,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^BGP8UTL2(P,$$FMADD^XLFDT(EDATE,-365),EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
QUIT 0
+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 IF '$DATA(^AUPNVMED(Y))
QUIT
+11 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+12 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+13 SET B=$$FMDIFF^XLFDT(EDATE,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+14 IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
IF $PIECE(^AUPNVMED(Y,0),U,7)'<B
SET D=1
End DoDot:1
+15 KILL ^TMP($JOB,"A"),BGPMEDS1
+16 QUIT D
HOSPPHAR(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^BGP8UTL2(T),U,2)
+14 IF T=""
QUIT
+15 IF '$$ICD^BGP8UTL2(T,$ORDER(^ATXAX("B","BGP PHARYNGITIS 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^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP GROUP A STREP CPT",0)),5)
+4 IF %]""
SET $PIECE(%,U,2)="CPT "_$PIECE(%,U,2)
QUIT 1_U_%
+5 SET %=$$TRAN^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP GROUP A STREP CPT",0)),5)
+6 IF %]""
SET $PIECE(%,U,2)="CPT "_$PIECE(%,U,2)
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_$PIECE(^LAB(60,$PIECE(^AUPNVLAB(X,0),U),0),U)
QUIT
+15 IF 'T
QUIT
+16 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+17 IF '$$LOINC^BGP8D21(J,T)
QUIT
+18 SET BGPC=1_U_(9999999-D)_U_$PIECE(^LAB(60,$PIECE(^AUPNVLAB(X,0),U),0),U)
+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_$PIECE(^LAB(60,$PIECE(^AUPNVMIC(X,0),U),0),U)
QUIT
+27 IF 'T
QUIT
+28 SET J=$PIECE($GET(^AUPNVMIC(X,11)),U,13)
IF J=""
QUIT
+29 IF '$$LOINC^BGP8D21(J,T)
QUIT
+30 SET BGPC=1_U_(9999999-D)_U_$PIECE(^LAB(60,$PIECE(^AUPNVMIC(X,0),U),0),U)
+31 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT BGPC
