- 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"
