BGP8D84 ; IHS/CMI/LAB - measure C ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;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 Y=$P($G(^AUPNVPOV(E,0)),U) I Y,'$$ICD^BGP8UTL2(Y,$O(^ATXAX("B","BGP URI 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=$$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^BGP8UTL2(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^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 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^BGP8UTL($P($P(^AUPNVSIT(V,0),U),"."))
K ^TMP($J,"A")
I D Q D
CANTIP ;check V PROCEDURE
S D=$$LASTPRC^BGP8UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
Q $P(D,U)_$S(D:"^antibiotic injection: "_$$DATE^BGP8UTL($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^BGP8UTL2(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^BGP8UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",$$FMADD^XLFDT(EDATE,-30),$$FMADD^XLFDT(EDATE,-1))
Q $P(D,U)_$S(D:"^antibiotic injection: "_$$DATE^BGP8UTL($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^BGP8UTL2(T),U,2)
...Q:T=""
...Q:'$$ICD^BGP8UTL2(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^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)))
I %]"" Q 1_U_%
S %=$$TRAN^BGP8DU(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^BGP8D21(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^BGP8D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"MICRO LOINC"
...Q
Q BGPC
HEPC ;
G HEPC^BGP8D841
BGP8D84 ; IHS/CMI/LAB - measure C ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;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 Y=$PIECE($GET(^AUPNVPOV(E,0)),U)
IF Y
IF '$$ICD^BGP8UTL2(Y,$ORDER(^ATXAX("B","BGP URI 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=$$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^BGP8UTL2(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^BGP8UTL1(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^BGP8UTL2(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^BGP8UTL($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^BGP8UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
+2 QUIT $PIECE(D,U)_$SELECT(D:"^antibiotic injection: "_$$DATE^BGP8UTL($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^BGP8UTL2(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^BGP8UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",$$FMADD^XLFDT(EDATE,-30),$$FMADD^XLFDT(EDATE,-1))
+2 QUIT $PIECE(D,U)_$SELECT(D:"^antibiotic injection: "_$$DATE^BGP8UTL($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^BGP8UTL2(T),U,2)
+14 IF T=""
QUIT
+15 IF '$$ICD^BGP8UTL2(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^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP GROUP A STREP CPT",0)))
+4 IF %]""
QUIT 1_U_%
+5 SET %=$$TRAN^BGP8DU(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^BGP8D21(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^BGP8D21(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 GOTO HEPC^BGP8D841
