- BGP6D84 ; IHS/CMI/LAB - measure C ;
- ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
- ;
- 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^BGP6UTL2(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^BGP6UTL1(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^BGP6UTL2(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^BGP6UTL($P($P(^AUPNVSIT(V,0),U),"."))
- K ^TMP($J,"A")
- I D Q D
- CANTIP ;check V PROCEDURE
- S D=$$LASTPRC^BGP6UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
- Q $P(D,U)_$S(D:"^antibiotic injection: "_$$DATE^BGP6UTL($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^BGP6UTL2(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^BGP6UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",$$FMADD^XLFDT(EDATE,-30),$$FMADD^XLFDT(EDATE,-1))
- Q $P(D,U)_$S(D:"^antibiotic injection: "_$$DATE^BGP6UTL($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^BGP6UTL2(T),U,2)
- ...Q:T=""
- ...Q:'$$ICD^BGP6UTL2(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^BGP6DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)))
- I %]"" Q 1_U_%
- S %=$$TRAN^BGP6DU(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^BGP6D21(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^BGP6D21(J,T)
- ...S BGPC=1_U_(9999999-D)_U_"MICRO LOINC"
- ...Q
- Q BGPC
- HEPC ;
- G HEPC^BGP6D841
- BGP6D84 ; IHS/CMI/LAB - measure C ;
- +1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
- +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^BGP6UTL2(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^BGP6UTL1(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^BGP6UTL2(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^BGP6UTL($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^BGP6UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
- +2 QUIT $PIECE(D,U)_$SELECT(D:"^antibiotic injection: "_$$DATE^BGP6UTL($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^BGP6UTL2(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^BGP6UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",$$FMADD^XLFDT(EDATE,-30),$$FMADD^XLFDT(EDATE,-1))
- +2 QUIT $PIECE(D,U)_$SELECT(D:"^antibiotic injection: "_$$DATE^BGP6UTL($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^BGP6UTL2(T),U,2)
- +14 IF T=""
- QUIT
- +15 IF '$$ICD^BGP6UTL2(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^BGP6DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP GROUP A STREP CPT",0)))
- +4 IF %]""
- QUIT 1_U_%
- +5 SET %=$$TRAN^BGP6DU(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^BGP6D21(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^BGP6D21(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^BGP6D841