- 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
