BGP8PC8 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
CCS ;EP
S (BGPN1,BGPD1)=0
S BGPDV=""
I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP=1 Q ;female only
I BGPAGEE<23 S BGPSTOP=1 Q ;18 or greater during time period
I BGPAGEB>63 S BGPSTOP=1 Q ;63 or less during time period
;
S BGPDV=$$ENC8(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 $$HYSTER(DFN,BGPEDATE) S BGPSTOP=1 Q
;
S BGPD1=1
;
S BGPVAL=""
S X=$$PAP(DFN,BGPEDATE,3) ;PAP IN 3 YRS?
I $E(X)=1 S BGPN1=1,BGPVAL=X
I 'BGPN1,BGPAGEB>29,BGPAGEB<65 S X=$$PAPHPV(DFN,BGPEDATE,5) I $E(X)=1 S BGPN1=1,BGPVAL=X ;PAP AND HPV IN PAST 5 YEARS ON SAME DAY
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
ENC8(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,$$OFFCPT8(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,$$OFFCPT8(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
Q G
OFFCPT8(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
Q ""
PAP(P,EDATE,YEARS,REFUSAL) ;EP
NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP
S BGPC=""
S BGPLPAP=""
S BDATE=($E(EDATE,1,3)-YEARS)_$E(EDATE,4,7)
;S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
S T=$O(^ATXAX("B","BGP IPC PAP LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP PAP SMEAR 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)!(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)=""
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="1^"_(9999999-D)_"^Lab" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPC="1^"_(9999999-D)_"^Lab-loinc" Q
...Q
S BGPLPAP=BGPC
I BGPLPAP]"" Q BGPLPAP
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 ""
HYSTER(P,EDATE) ;EP
I '$G(P) Q ""
NEW X,T
S X=$$LASTPRC^BGP8UTL1(P,"BGP HYSTERECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
I X Q 1
S T="HYSTERECTOMY",T=$O(^BWPN("B",T,0))
I T D I X]"" Q 1
.S X=$$WH^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
S T=$O(^ATXAX("B","BGP IPC HYSTERECTOMY CPTS",0))
I T D I X]"" Q 1
.S X=$$CPT^BGP8DU(P,$P(^DPT(P,0),U,3),EDATE,T,3) I X]"" Q
.S X=$$TRAN^BGP8DU(P,$P(^DPT(P,0),U,3),EDATE,T,3)
S X=$$LASTDX^BGP8UTL1(P,"BGP HYSTERECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
I X Q 1
S X=$$PLTAXND^BGP8DU(P,"BGP HYSTERECTOMY DXS",EDATE)
I X Q 1
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP HYSTERECTOMY DX",EDATE)
I X Q 1
Q ""
PAPHPV(P,EDATE,YEARS) ;EP - PAP AND HPV ON THE SAME DAY
NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP,BGPAPAP,BGPG,BGPAHPV
;GATHER UP ALL PAP SMEARS BY DATE
;BGPAPAP(INVERSE DATE)=1^INTERNAL DATE^VALUE
S BGPC="",BGPLPAP="",BGPAHPV="",BGPAPAP=""
;S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
S BDATE=($E(EDATE,1,3)-YEARS)_$E(EDATE,4,7)
S T=$O(^ATXAX("B","BGP IPC PAP LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP PAP SMEAR 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))
...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 BGPAPAP(D)="1^"_(9999999-D)_"^Lab" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPAPAP(D)="1^"_(9999999-D)_"^Lab-loinc" Q
...Q
;GATHER UP ALL HPV TESTS
HPV ;
S BGPC=""
K BGPAHPV
S BDATE=($E(EDATE,1,3)-YEARS)_$E(EDATE,4,7)
;S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
S T=$O(^ATXAX("B","BGP IPC HPV LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP HPV TESTS 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))
...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 BGPAHPV(D)="1^"_(9999999-D)_"^Lab" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPAHPV(D)="1^"_(9999999-D)_"^Lab-loinc" Q
...Q
;LOOP ALL PAPS AND SEE IF HPV ON SAME DAY, IF SO CHECK AGAINST BGPLPAP AND IF LATER QUIT
S D=0 F S D=$O(BGPAPAP(D)) Q:D'=+D D
.I $D(BGPAHPV(D)),$P(BGPAPAP(D),U,2)>$P(BGPLPAP,U,2) S BGPLPAP="1^"_$P(BGPAPAP(D),U,2)_U_"PAP&HPV 5YRS SAME DAY"
Q BGPLPAP
BGP8PC8 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
CCS ;EP
+1 SET (BGPN1,BGPD1)=0
+2 SET BGPDV=""
+3 ;female only
IF $PIECE(^DPT(DFN,0),U,2)'="F"
SET BGPSTOP=1
QUIT
+4 ;18 or greater during time period
IF BGPAGEE<23
SET BGPSTOP=1
QUIT
+5 ;63 or less during time period
IF BGPAGEB>63
SET BGPSTOP=1
QUIT
+6 ;
+7 ;no office visit
SET BGPDV=$$ENC8(DFN,BGPBDATE,BGPEDATE)
IF BGPDV=""
SET BGPSTOP=1
QUIT
+8 ;
+9 ;now what about exclusions?
+10 ;no hospice pts
IF $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+11 ;Hysterectomy?
+12 IF $$HYSTER(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+13 ;
+14 SET BGPD1=1
+15 ;
+16 SET BGPVAL=""
+17 ;PAP IN 3 YRS?
SET X=$$PAP(DFN,BGPEDATE,3)
+18 IF $EXTRACT(X)=1
SET BGPN1=1
SET BGPVAL=X
+19 ;PAP AND HPV IN PAST 5 YEARS ON SAME DAY
IF 'BGPN1
IF BGPAGEB>29
IF BGPAGEB<65
SET X=$$PAPHPV(DFN,BGPEDATE,5)
IF $EXTRACT(X)=1
SET BGPN1=1
SET BGPVAL=X
+20 SET BGPVALUE=""
+21 ;hit denominator
SET BGPVALUE="ENC "_$PIECE(BGPDV,U,2)_"|||"
+22 IF BGPN1
SET BGPVALUE=BGPVALUE_"*** "_$$DATE^BGP8UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
+23 KILL V,BGPDV,BGPVAL
+24 QUIT
ENC8(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 $$OFFCPT8(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 $$OFFCPT8(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
OFFCPT8(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 QUIT ""
PAP(P,EDATE,YEARS,REFUSAL) ;EP
+1 NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP
+2 SET BGPC=""
+3 SET BGPLPAP=""
+4 SET BDATE=($EXTRACT(EDATE,1,3)-YEARS)_$EXTRACT(EDATE,4,7)
+5 ;S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
+6 SET T=$ORDER(^ATXAX("B","BGP IPC PAP LOINC CODES",0))
+7 SET BGPLT=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+8 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
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+13 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC="1^"_(9999999-D)_"^Lab"
QUIT
+14 IF 'T
QUIT
+15 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+16 IF '$$LOINC(J,T)
QUIT
+17 SET BGPC="1^"_(9999999-D)_"^Lab-loinc"
QUIT
+18 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET BGPLPAP=BGPC
+20 IF BGPLPAP]""
QUIT BGPLPAP
+21 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 ""
HYSTER(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW X,T
+3 SET X=$$LASTPRC^BGP8UTL1(P,"BGP HYSTERECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
+4 IF X
QUIT 1
+5 SET T="HYSTERECTOMY"
SET T=$ORDER(^BWPN("B",T,0))
+6 IF T
Begin DoDot:1
+7 SET X=$$WH^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
End DoDot:1
IF X]""
QUIT 1
+8 SET T=$ORDER(^ATXAX("B","BGP IPC HYSTERECTOMY CPTS",0))
+9 IF T
Begin DoDot:1
+10 SET X=$$CPT^BGP8DU(P,$PIECE(^DPT(P,0),U,3),EDATE,T,3)
IF X]""
QUIT
+11 SET X=$$TRAN^BGP8DU(P,$PIECE(^DPT(P,0),U,3),EDATE,T,3)
End DoDot:1
IF X]""
QUIT 1
+12 SET X=$$LASTDX^BGP8UTL1(P,"BGP HYSTERECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
+13 IF X
QUIT 1
+14 SET X=$$PLTAXND^BGP8DU(P,"BGP HYSTERECTOMY DXS",EDATE)
+15 IF X
QUIT 1
+16 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP HYSTERECTOMY DX",EDATE)
+17 IF X
QUIT 1
+18 QUIT ""
PAPHPV(P,EDATE,YEARS) ;EP - PAP AND HPV ON THE SAME DAY
+1 NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP,BGPAPAP,BGPG,BGPAHPV
+2 ;GATHER UP ALL PAP SMEARS BY DATE
+3 ;BGPAPAP(INVERSE DATE)=1^INTERNAL DATE^VALUE
+4 SET BGPC=""
SET BGPLPAP=""
SET BGPAHPV=""
SET BGPAPAP=""
+5 ;S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
+6 SET BDATE=($EXTRACT(EDATE,1,3)-YEARS)_$EXTRACT(EDATE,4,7)
+7 SET T=$ORDER(^ATXAX("B","BGP IPC PAP LOINC CODES",0))
+8 SET BGPLT=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+9 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
+10 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+12 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+13 ;must have a result
IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+14 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPAPAP(D)="1^"_(9999999-D)_"^Lab"
QUIT
+15 IF 'T
QUIT
+16 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+17 IF '$$LOINC(J,T)
QUIT
+18 SET BGPAPAP(D)="1^"_(9999999-D)_"^Lab-loinc"
QUIT
+19 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;GATHER UP ALL HPV TESTS
HPV ;
+1 SET BGPC=""
+2 KILL BGPAHPV
+3 SET BDATE=($EXTRACT(EDATE,1,3)-YEARS)_$EXTRACT(EDATE,4,7)
+4 ;S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
+5 SET T=$ORDER(^ATXAX("B","BGP IPC HPV LOINC CODES",0))
+6 SET BGPLT=$ORDER(^ATXLAB("B","BGP HPV TESTS TAX",0))
+7 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
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 ;must have a result
IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+12 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPAHPV(D)="1^"_(9999999-D)_"^Lab"
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC(J,T)
QUIT
+16 SET BGPAHPV(D)="1^"_(9999999-D)_"^Lab-loinc"
QUIT
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;LOOP ALL PAPS AND SEE IF HPV ON SAME DAY, IF SO CHECK AGAINST BGPLPAP AND IF LATER QUIT
+19 SET D=0
FOR
SET D=$ORDER(BGPAPAP(D))
IF D'=+D
QUIT
Begin DoDot:1
+20 IF $DATA(BGPAHPV(D))
IF $PIECE(BGPAPAP(D),U,2)>$PIECE(BGPLPAP,U,2)
SET BGPLPAP="1^"_$PIECE(BGPAPAP(D),U,2)_U_"PAP&HPV 5YRS SAME DAY"
End DoDot:1
+21 QUIT BGPLPAP
