BGP8D864 ; IHS/CMI/LAB - measure C ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
NDC(A,B) ;
S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)
I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
Q 0
GOLDLAB(P,BDATE,EDATE) ;EP
K BGPIM,BGPLAB
K BGPMEDS1
D GETMEDS^BGP8UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) Q ""
S T1=$O(^ATXAX("B","BGP RA IM GOLD MEDS",0))
S T4=$O(^ATXAX("B","BGP RA IM GOLD NDC",0))
S X=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X 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:Z="" ;BAD POINTER
.I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)),$P(^AUPNVMED(Y,0),U,8)="" S BGPIM($P($P(^AUPNVSIT(V,0),U),"."))=""
I '$D(BGPIM) Q "" ;no gold im
;CBC'S
K BGPC
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(85027),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(85027),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC($P(%,U,2))=""
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP CBC LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP CBC 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) 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(9999999-D)="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC(9999999-D)=""
...Q
I '$D(BGPC) Q "0^no CBC tests"
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
;S (X,Y)="",C=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1 D
;.I C=1 S Y=X Q
;.I $$FMDIFF^XLFDT(X,Y)<11 K BGPC(X) Q
;.S Y=X
;check to see if there is one for every med
S G=1,X=0 F S X=$O(BGPIM(X)) Q:X'=+X I '$D(BGPC(X)) S G=0
I 'G Q G_U_"no CBC for each IM GOLD"
;now urine protein
K BGPC
S T=$O(^ATXAX("B","BGP URINE PROTEIN LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT URINE PROTEIN 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))) D
....S BGPC(9999999-D)="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC(9999999-D)=""
...Q
I '$D(BGPC) Q "0^no Urine Protein tests"
S G=1,X=0 F S X=$O(BGPIM(X)) Q:X'=+X I '$D(BGPC(X)) S G=0
I 'G Q G_U_"no Urine Protein for each IM GOLD"
Q 1_U_"CBC and Urine protein w/each IM Gold"
BGP8D864 ; IHS/CMI/LAB - measure C ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
NDC(A,B) ;
+1 SET BGPNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+2 IF BGPNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BGPNDC))
QUIT 1
+3 QUIT 0
GOLDLAB(P,BDATE,EDATE) ;EP
+1 KILL BGPIM,BGPLAB
+2 KILL BGPMEDS1
+3 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+4 IF '$DATA(BGPMEDS1)
QUIT ""
+5 SET T1=$ORDER(^ATXAX("B","BGP RA IM GOLD MEDS",0))
+6 SET T4=$ORDER(^ATXAX("B","BGP RA IM GOLD NDC",0))
+7 SET X=0
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+10 ;BAD POINTER
IF Z=""
QUIT
+11 IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
IF $PIECE(^AUPNVMED(Y,0),U,8)=""
SET BGPIM($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))=""
End DoDot:1
+12 ;no gold im
IF '$DATA(BGPIM)
QUIT ""
+13 ;CBC'S
+14 KILL BGPC
+15 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+16 IF %]""
SET BGPC($PIECE(%,U,2))=""
+17 SET %=""
SET E=+$$CODEN^ICPTCOD(85027)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+18 IF %]""
SET BGPC($PIECE(%,U,2))=""
+19 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+20 IF %]""
SET BGPC($PIECE(%,U,2))=""
+21 SET %=""
SET E=+$$CODEN^ICPTCOD(85027)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+22 IF %]""
SET BGPC($PIECE(%,U,2))=""
+23 ;now get all loinc/taxonomy tests
+24 SET T=$ORDER(^ATXAX("B","BGP CBC LOINC",0))
+25 SET BGPLT=$ORDER(^ATXLAB("B","BGP CBC TESTS",0))
+26 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
+27 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+29 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+30 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC(9999999-D)=""
QUIT
+31 IF 'T
QUIT
+32 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+33 IF '$$LOINC^BGP8D21(J,T)
QUIT
+34 SET BGPC(9999999-D)=""
+35 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+36 IF '$DATA(BGPC)
QUIT "0^no CBC tests"
+37 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+38 ;S (X,Y)="",C=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1 D
+39 ;.I C=1 S Y=X Q
+40 ;.I $$FMDIFF^XLFDT(X,Y)<11 K BGPC(X) Q
+41 ;.S Y=X
+42 ;check to see if there is one for every med
+43 SET G=1
SET X=0
FOR
SET X=$ORDER(BGPIM(X))
IF X'=+X
QUIT
IF '$DATA(BGPC(X))
SET G=0
+44 IF 'G
QUIT G_U_"no CBC for each IM GOLD"
+45 ;now urine protein
+46 KILL BGPC
+47 SET T=$ORDER(^ATXAX("B","BGP URINE PROTEIN LOINC CODES",0))
+48 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))
+49 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
+50 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+51 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+52 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+53 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+54 SET BGPC(9999999-D)=""
QUIT
End DoDot:4
+55 IF 'T
QUIT
+56 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+57 IF '$$LOINC^BGP8D21(J,T)
QUIT
+58 SET BGPC(9999999-D)=""
+59 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+60 IF '$DATA(BGPC)
QUIT "0^no Urine Protein tests"
+61 SET G=1
SET X=0
FOR
SET X=$ORDER(BGPIM(X))
IF X'=+X
QUIT
IF '$DATA(BGPC(X))
SET G=0
+62 IF 'G
QUIT G_U_"no Urine Protein for each IM GOLD"
+63 QUIT 1_U_"CBC and Urine protein w/each IM Gold"
