BGP8PC10 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
CRC ;EP
I BGPAGEE<50 S BGPSTOP=1 Q ;18 or greater during time period
I BGPAGEB>74 S BGPSTOP=1 Q ;LESS THAN 75 during time period
;
S BGPDV=$$ENC10(DFN,BGPBDATE,BGPEDATE) I BGPDV="" S BGPSTOP=1 Q ;no office visit
;
;now what about exclusions?
I $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q ;no hospice pts
;Hysterectomy?
I $$CRCCOLE(DFN,BGPEDATE) S BGPSTOP=1 Q
;
S (BGPN1,BGPD1)=0
;
S BGPD1=1
;
S BGPVAL=""
S X=$$SCREEN(DFN,BGPBDATE,BGPEDATE)
I X S BGPN1=1,BGPVAL=$P(X,U,2)_" "_$P(X,U,3)
SV ;
S BGPVALUE=""
S BGPVALUE="ENC "_$P(BGPDV,U,2)_"|||" ;hit denominator
I BGPN1 S BGPVALUE=BGPVALUE_"*** "_$$DATE^BGP8UTL($P(X,U,2))_" "_$P(X,U,3)
K V,BGPDV,BGPVAL
Q
ENC10(P,BDATE,EDATE) ;EP - have encounter per CMS122v6
;HAS one of the following
;1. cpt in BGP IPC OFFICE VISIT CPTS
;2. snomed in PXRM BGP IPC FACE2FACE
;3. CPT in BGP IPC PREVCARE EOV >=18 CPTS
;4. CPT in BGP IPC PREVCARE IOV >=18 CPTS
;5. CPT in BGP IPC HOMEHEALTH VISIT CPTS
NEW X,Y,Z,G,BGPV,D
;Let's check all Visits, looping through once
S G="" ;return variable
;get all visits in date range in BGPV
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
S X=0 F S X=$O(BGPV(X)) Q:X'=+X!(G) S V=$P(BGPV(X),U,5) D
.Q:'$P(^AUPNVSIT(V,0),U,9) ;no dependent entries
.Q:$P(^AUPNVSIT(V,0),U,11) ;deleted
.S D=$$VD^APCLV(V)
.S Y=$$FTOF^BGP8PC2(V) I Y]"" S G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y Q
.;is .17 a cpt we want?
.S Y=$$VALI^XBDIQ1(9000010,V,.17)
.I Y,$$OFFCPT10(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
.;now check all V CPTs
.S Z=0 F S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(G) D
..S Y=$P($G(^AUPNVCPT(Z,0)),U,1)
..I Y,$$OFFCPT10(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
Q G
OFFCPT10(C) ;EP
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE EOV >=18 CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE IOV >=18 CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC ANNUAL WELLNESS CPTS",0)),1) Q 1
Q ""
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
CRCCOLE(P,EDATE) ;EP
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP IPC COLON CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1 ;has a dx
S X=$$PLTAXND^BGP8DU(P,"BGP IPC COLON CANCER DXS",EDATE)
I X Q 1
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP IPC COLON CANCER",EDATE)
I X Q 1
S T=$O(^ATXAX("B","BGP IPC TOTAL COLECTOMY CPTS",0))
I T D I X]"" Q 1
.S X=$$CPT^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
Q 0
SCREEN(P,BDATE,EDATE) ;
NEW X,Y,Z,BGPC,G,V,D
S G=$$COLO(P,($E(EDATE,1,3)-9)_$E(EDATE,4,7),EDATE)
I G Q G
S G=$$FOBT(P,BDATE,EDATE)
I G Q G
S G=$$SIG(P,($E(EDATE,1,3)-4)_$E(EDATE,4,7),EDATE)
I G Q G
S G=$$FIT(P,($E(EDATE,1,3)-2)_$E(EDATE,4,7),EDATE)
I G Q G
S G=$$CT(P,($E(EDATE,1,3)-4)_$E(EDATE,4,7),EDATE)
I G Q G
Q ""
COLO(P,BDATE,EDATE) ;
NEW BGPG,BGPLCOLO,T,X
K BGPG
S BGPLCOLO=""
S T=$O(^ATXAX("B","BGP IPC COLONOSCOPY CPTS",0))
I T D I X]"",$P(BGPLCOLO,U,3)<$P(X,U,1) S BGPLCOLO=1_U_$P(X,U,1)_U_"COLO CPT "_$P(X,U,2)
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
Q BGPLCOLO
SIG(P,BDATE,EDATE) ;
NEW BGPG,BGPLCOLO,T,X
K BGPG
S BGPLCOLO=""
S T=$O(^ATXAX("B","BGP IPC SIG CPT CODES",0))
I T D I X]"",$P(BGPLCOLO,U,3)<$P(X,U,1) S BGPLCOLO=1_U_$P(X,U,1)_U_"SIG CPT "_$P(X,U,2)
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
Q BGPLCOLO
FOBT(P,BDATE,EDATE) ;EP
NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
S BGPC="",BGPLFOB=""
S T=$O(^ATXAX("B","BGP IPC FOBT LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP GPRA FOB 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)!(BGPC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)="" ;must have a result
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="Lab"_U_(9999999-D) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPC="LOINC"_U_(9999999-D) Q
...Q
I BGPC]"" Q 1_U_$P(BGPC,U,2)_U_"FOBT "_$P(BGPC,U,1)
Q ""
;
CT(P,BDATE,EDATE) ;EP - CT COLONOGRAPHY
NEW BGPLCT,T,X,BGPG
S BGPLCT=""
;
S T=$O(^ATXAX("B","BGP IPC CT COLONOGRAPHY CPTS",0))
I T D I X]"" S BGPLCT=1_U_$P(X,U,1)_U_"CT CPT "_$P(X,U,2)
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
Q BGPLCT
;
FIT(P,BDATE,EDATE) ;EP
NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
S BGPC="",BGPLFOB=""
S T=$O(^ATXAX("B","BGP IPC FIT-DNA LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP FIT-DNA 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)!(BGPC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...I $P(^AUPNVLAB(X,0),U,4)="" Q
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="FIT-DNA Lab"_U_(9999999-D) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPC="LOINC"_U_(9999999-D) Q
...Q
I BGPC]"" Q 1_U_$P(BGPC,U,2)_U_"FIT-DNA "_$P(BGPC,U,1)
Q ""
;
BGP8PC10 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
CRC ;EP
+1 ;18 or greater during time period
IF BGPAGEE<50
SET BGPSTOP=1
QUIT
+2 ;LESS THAN 75 during time period
IF BGPAGEB>74
SET BGPSTOP=1
QUIT
+3 ;
+4 ;no office visit
SET BGPDV=$$ENC10(DFN,BGPBDATE,BGPEDATE)
IF BGPDV=""
SET BGPSTOP=1
QUIT
+5 ;
+6 ;now what about exclusions?
+7 ;no hospice pts
IF $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+8 ;Hysterectomy?
+9 IF $$CRCCOLE(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+10 ;
+11 SET (BGPN1,BGPD1)=0
+12 ;
+13 SET BGPD1=1
+14 ;
+15 SET BGPVAL=""
+16 SET X=$$SCREEN(DFN,BGPBDATE,BGPEDATE)
+17 IF X
SET BGPN1=1
SET BGPVAL=$PIECE(X,U,2)_" "_$PIECE(X,U,3)
SV ;
+1 SET BGPVALUE=""
+2 ;hit denominator
SET BGPVALUE="ENC "_$PIECE(BGPDV,U,2)_"|||"
+3 IF BGPN1
SET BGPVALUE=BGPVALUE_"*** "_$$DATE^BGP8UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
+4 KILL V,BGPDV,BGPVAL
+5 QUIT
ENC10(P,BDATE,EDATE) ;EP - have encounter per CMS122v6
+1 ;HAS one of the following
+2 ;1. cpt in BGP IPC OFFICE VISIT CPTS
+3 ;2. snomed in PXRM BGP IPC FACE2FACE
+4 ;3. CPT in BGP IPC PREVCARE EOV >=18 CPTS
+5 ;4. CPT in BGP IPC PREVCARE IOV >=18 CPTS
+6 ;5. CPT in BGP IPC HOMEHEALTH VISIT CPTS
+7 NEW X,Y,Z,G,BGPV,D
+8 ;Let's check all Visits, looping through once
+9 ;return variable
SET G=""
+10 ;get all visits in date range in BGPV
+11 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+12 ;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
+13 SET X=0
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(BGPV(X),U,5)
Begin DoDot:1
+14 ;no dependent entries
IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+15 ;deleted
IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+16 SET D=$$VD^APCLV(V)
+17 SET Y=$$FTOF^BGP8PC2(V)
IF Y]""
SET G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y
QUIT
+18 ;is .17 a cpt we want?
+19 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+20 IF Y
IF $$OFFCPT10(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
+21 ;now check all V CPTs
+22 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+23 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+24 IF Y
IF $$OFFCPT10(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
End DoDot:2
End DoDot:1
+25 QUIT G
OFFCPT10(C) ;EP
+1 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1)
QUIT 1
+2 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE EOV >=18 CPTS",0)),1)
QUIT 1
+3 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE IOV >=18 CPTS",0)),1)
QUIT 1
+4 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1)
QUIT 1
+5 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC ANNUAL WELLNESS CPTS",0)),1)
QUIT 1
+6 QUIT ""
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
CRCCOLE(P,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^LAST DX [BGP IPC COLON CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 ;has a dx
IF $DATA(BGPG(1))
QUIT 1
+5 SET X=$$PLTAXND^BGP8DU(P,"BGP IPC COLON CANCER DXS",EDATE)
+6 IF X
QUIT 1
+7 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP IPC COLON CANCER",EDATE)
+8 IF X
QUIT 1
+9 SET T=$ORDER(^ATXAX("B","BGP IPC TOTAL COLECTOMY CPTS",0))
+10 IF T
Begin DoDot:1
+11 SET X=$$CPT^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+12 SET X=$$TRAN^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1
+13 QUIT 0
SCREEN(P,BDATE,EDATE) ;
+1 NEW X,Y,Z,BGPC,G,V,D
+2 SET G=$$COLO(P,($EXTRACT(EDATE,1,3)-9)_$EXTRACT(EDATE,4,7),EDATE)
+3 IF G
QUIT G
+4 SET G=$$FOBT(P,BDATE,EDATE)
+5 IF G
QUIT G
+6 SET G=$$SIG(P,($EXTRACT(EDATE,1,3)-4)_$EXTRACT(EDATE,4,7),EDATE)
+7 IF G
QUIT G
+8 SET G=$$FIT(P,($EXTRACT(EDATE,1,3)-2)_$EXTRACT(EDATE,4,7),EDATE)
+9 IF G
QUIT G
+10 SET G=$$CT(P,($EXTRACT(EDATE,1,3)-4)_$EXTRACT(EDATE,4,7),EDATE)
+11 IF G
QUIT G
+12 QUIT ""
COLO(P,BDATE,EDATE) ;
+1 NEW BGPG,BGPLCOLO,T,X
+2 KILL BGPG
+3 SET BGPLCOLO=""
+4 SET T=$ORDER(^ATXAX("B","BGP IPC COLONOSCOPY CPTS",0))
+5 IF T
Begin DoDot:1
+6 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+7 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLCOLO,U,3)<$PIECE(X,U,1)
SET BGPLCOLO=1_U_$PIECE(X,U,1)_U_"COLO CPT "_$PIECE(X,U,2)
+8 QUIT BGPLCOLO
SIG(P,BDATE,EDATE) ;
+1 NEW BGPG,BGPLCOLO,T,X
+2 KILL BGPG
+3 SET BGPLCOLO=""
+4 SET T=$ORDER(^ATXAX("B","BGP IPC SIG CPT CODES",0))
+5 IF T
Begin DoDot:1
+6 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+7 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLCOLO,U,3)<$PIECE(X,U,1)
SET BGPLCOLO=1_U_$PIECE(X,U,1)_U_"SIG CPT "_$PIECE(X,U,2)
+8 QUIT BGPLCOLO
FOBT(P,BDATE,EDATE) ;EP
+1 NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
+2 SET BGPC=""
SET BGPLFOB=""
+3 SET T=$ORDER(^ATXAX("B","BGP IPC FOBT LOINC CODES",0))
+4 SET BGPLT=$ORDER(^ATXLAB("B","BGP GPRA FOB TESTS",0))
+5 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)!(BGPC]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 ;must have a result
IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+10 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC="Lab"_U_(9999999-D)
QUIT
+11 IF 'T
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC(J,T)
QUIT
+14 SET BGPC="LOINC"_U_(9999999-D)
QUIT
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF BGPC]""
QUIT 1_U_$PIECE(BGPC,U,2)_U_"FOBT "_$PIECE(BGPC,U,1)
+17 QUIT ""
+18 ;
CT(P,BDATE,EDATE) ;EP - CT COLONOGRAPHY
+1 NEW BGPLCT,T,X,BGPG
+2 SET BGPLCT=""
+3 ;
+4 SET T=$ORDER(^ATXAX("B","BGP IPC CT COLONOGRAPHY CPTS",0))
+5 IF T
Begin DoDot:1
+6 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+7 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
SET BGPLCT=1_U_$PIECE(X,U,1)_U_"CT CPT "_$PIECE(X,U,2)
+8 QUIT BGPLCT
+9 ;
FIT(P,BDATE,EDATE) ;EP
+1 NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
+2 SET BGPC=""
SET BGPLFOB=""
+3 SET T=$ORDER(^ATXAX("B","BGP IPC FIT-DNA LOINC CODES",0))
+4 SET BGPLT=$ORDER(^ATXLAB("B","BGP FIT-DNA TESTS",0))
+5 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)!(BGPC]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+10 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC="FIT-DNA Lab"_U_(9999999-D)
QUIT
+11 IF 'T
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC(J,T)
QUIT
+14 SET BGPC="LOINC"_U_(9999999-D)
QUIT
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF BGPC]""
QUIT 1_U_$PIECE(BGPC,U,2)_U_"FIT-DNA "_$PIECE(BGPC,U,1)
+17 QUIT ""
+18 ;
