BGP8D21A ; IHS/CMI/LAB - measure 6 ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
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 ""
EYEENUC(P,EDATE) ;EP
NEW X,T,G,R,L,Y,C,RI,LF,BGPX,C,Y,M
;first check for PROCEDURES
S BDATE=$$DOB^AUPNPAT(P)
S RI=$$LASTPRC^BGP8UTL1(P,"BGP RIGHT EYE ENUCLEATION PROC",BDATE,EDATE)
S LF=$$LASTPRC^BGP8UTL1(P,"BGP LEFT EYE ENUCLEATION PROCS",BDATE,EDATE)
I RI,LF Q 1
;NOW CHECK CPTS
;ONE WITH MODIFER 50 09950 OR 2 AT LEAST 14 DAYS APART
;check cpt codes for bilateral
;loop through all cpt codes up to Edate and if any match quit
S (X,Y,Z,G)=0 K BGPX
S T=$O(^ATXAX("B","BGP EYE ENUCLEATION CPTS",0))
I T S %="" D I %]"" Q 1
.S Y=0 F S Y=$O(^AUPNVCPT("AC",P,Y)) Q:Y'=+Y!(%]"") D
..S D=$P($G(^AUPNVCPT(Y,0)),U,3)
..Q:D=""
..S D=$P($P($G(^AUPNVSIT(D,0)),U),".") ;date done
..Q:D=""
..I D>EDATE Q
..S X=$P(^AUPNVCPT(Y,0),U)
..Q:'$$ICD^BGP8UTL2(X,T,1)
..S BGPX(D)=""
..I ^DD(9000010.18,.08,0)["AUTTCMOD" S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..I ^DD(9000010.18,.09,0)["AUTTCMOD" S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..I ^DD(9000010.18,.08,0)["DIC(81.3" S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1
..I ^DD(9000010.18,.09,0)["DIC(81.3" S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1
..Q:%
.Q
; now check tran codes
I T,$D(^AUPNVTC("AC",P)) S %="" D I %]"" Q 1
.S E=0 F S E=$O(^AUPNVTC("AC",P,E)) Q:E'=+E!(%]"") D
..S D=$P($G(^AUPNVTC(E,0)),U,3) Q:'D S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
..Q:'$$ICD^BGP8UTL2($P(^AUPNVTC(E,0),U,7),T,1)
..I D>EDATE Q
..S BGPX(D)=""
..I '$D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..I '$D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..I $D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1
..I $D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1
..Q:%
..S M=""
..Q
.Q
;see if 2 on different dates 14 DAYS APART
S (X,Y)="",C=0 F S X=$O(BGPX(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<14 K BGPX(X) Q
.S Y=X
;count
S C=0,X=0 F S X=$O(BGPX(X)) Q:X'=+X S C=C+1
I C>1 Q 1
Q ""
BLINDPL(P,EDATE) ;EP
NEW X,T,G,R,L,Y,C
S X=$$PLTAXND^BGP8DU(P,"BGP BILATERAL BLINDNESS DXS",EDATE)
I X Q 1
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP BILAT BLINDNESS",EDATE)
I X Q 1
S T="PXRM BGP BLINDNESS UNSPECIFIED" ;CODE WITH LATERALITY=BILATERAL
;LOOP PROBLEM LIST
S (X,G,R,L)=""
F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
.S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
..Q:'$D(^AUPNPROB(Y,0))
..Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
..Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,T,X))
..I EDATE,$P(^AUPNPROB(Y,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
..I $P(^AUPNPROB(Y,0),U,13)="",EDATE,$P(^AUPNPROB(Y,0),U,8)>EDATE Q ;no doo, entered after report period, skip
..;IS LATERALITY BILATERAL:
..S C=$$VAL^XBDIQ1(9000011,Y,.22)
..I $$UP^XLFSTR(C)["BILATERAL" S G=1_U_"Problem List: "_X Q ;$$CONCPT^AUPNVUTL(X)
..I $$UP^XLFSTR(C)["LEFT" S L=1
..I $$UP^XLFSTR(C)["RIGHT" S R=1
I G Q G
I R,L Q 1_U_"Problem List: "_X
;NOW CHECK RIGHT AND LEFT SNOMED SUBSETS
NEW TR,TL
I 'R D
.S TR="PXRM BGP RIGHT EYE BLIND"
.;LOOP PROBLEM LIST
.S (X,G)=""
.F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
..S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
...Q:'$D(^AUPNPROB(Y,0))
...Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
...Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,TR,X))
...I EDATE,$P(^AUPNPROB(Y,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
...I $P(^AUPNPROB(Y,0),U,13)="",EDATE,$P(^AUPNPROB(Y,0),U,8)>EDATE Q ;no doo, entered after report period, skip
...S R=1
I R,L Q 1_U_"Problem List: "_X
I 'L D
.S TL="PXRM BGP LEFT EYE BLIND"
.;LOOP PROBLEM LIST
.S (X,G)=""
.F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
..S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
...Q:'$D(^AUPNPROB(Y,0))
...Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
...Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,TL,X))
...I EDATE,$P(^AUPNPROB(Y,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
...I $P(^AUPNPROB(Y,0),U,13)="",EDATE,$P(^AUPNPROB(Y,0),U,8)>EDATE Q ;no doo, entered after report period, skip
...S L=1
I R,L Q 1_U_"Problem List: "_X
Q ""
CHDPL(P,EDATE) ;EP - is dx on problem list as either active or inactive?
NEW T,T1,T2,T3,SN1,SN2,SN3,SN4,T4,T5,SN5,SN6,SN7,SN8
S T=$O(^ATXAX("B","BGP CHD DXS",0))
S T1=$O(^ATXAX("B","BGP AMI DXS PAMT",0))
S T2=$O(^ATXAX("B","BGP IVD DXS",0))
S T3=$O(^ATXAX("B","BGP TIA DXS",0))
S T4=$O(^ATXAX("B","BGP ARTERIAL DISEASE DXS",0))
S SN1="PXRM ISCHEMIC HEART DISEASE"
S SN2="PXRM BGP AMI"
S SN3="PXRM BGP IVD"
S SN4="PXRM BGP ISCHEMIC STROKE TIA"
S SN5="PXRM BGP ARTERIAL DISEASE"
S SN6="PXRM BGP CABG"
S SN7="PXRM BGP PCI"
S SN8="PXRM BGP CAROTID INTERVENTION"
PL ;
NEW X,Y,I,S
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.S Y=$P(^AUPNPROB(X,0),U)
.I EDATE,$P(^AUPNPROB(X,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",EDATE,$P(^AUPNPROB(X,0),U,8)>EDATE Q ;no doo, entered after report period, skip
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN1,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN2,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN3,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN4,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN5,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN6,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN7,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN8,S)) S I=1 Q
.I $$ICD^BGP8UTL2(Y,T,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.I $$ICD^BGP8UTL2(Y,T1,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.I $$ICD^BGP8UTL2(Y,T2,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.I $$ICD^BGP8UTL2(Y,T3,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.I $$ICD^BGP8UTL2(Y,T4,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.Q
Q I
HEPA(P,BDATE,EDATE) ;
;EP
NEW BGPG,E,Y,X
;S BDATE=$$DOB^AUPNPAT(P)
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP HEPATITIS A EVIDENCE;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1
I $$PLTAXND^BGP8DU(P,"BGP HEPATITIS A EVIDENCE",EDATE) Q 1
I $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS A",EDATE) Q 1
Q 0
HEPB(P,BDATE,EDATE) ;
;EP
NEW BGPG,E,Y,X
;S BDATE=$$DOB^AUPNPAT(P)
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1
I $$PLTAXND^BGP8DU(P,"BGP HEP EVIDENCE",EDATE) Q 1
I $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS B",EDATE) Q 1
Q 0
BGP8D21A ; IHS/CMI/LAB - measure 6 ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
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 ""
EYEENUC(P,EDATE) ;EP
+1 NEW X,T,G,R,L,Y,C,RI,LF,BGPX,C,Y,M
+2 ;first check for PROCEDURES
+3 SET BDATE=$$DOB^AUPNPAT(P)
+4 SET RI=$$LASTPRC^BGP8UTL1(P,"BGP RIGHT EYE ENUCLEATION PROC",BDATE,EDATE)
+5 SET LF=$$LASTPRC^BGP8UTL1(P,"BGP LEFT EYE ENUCLEATION PROCS",BDATE,EDATE)
+6 IF RI
IF LF
QUIT 1
+7 ;NOW CHECK CPTS
+8 ;ONE WITH MODIFER 50 09950 OR 2 AT LEAST 14 DAYS APART
+9 ;check cpt codes for bilateral
+10 ;loop through all cpt codes up to Edate and if any match quit
+11 SET (X,Y,Z,G)=0
KILL BGPX
+12 SET T=$ORDER(^ATXAX("B","BGP EYE ENUCLEATION CPTS",0))
+13 IF T
SET %=""
Begin DoDot:1
+14 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AC",P,Y))
IF Y'=+Y!(%]"")
QUIT
Begin DoDot:2
+15 SET D=$PIECE($GET(^AUPNVCPT(Y,0)),U,3)
+16 IF D=""
QUIT
+17 ;date done
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+18 IF D=""
QUIT
+19 IF D>EDATE
QUIT
+20 SET X=$PIECE(^AUPNVCPT(Y,0),U)
+21 IF '$$ICD^BGP8UTL2(X,T,1)
QUIT
+22 SET BGPX(D)=""
+23 IF ^DD(9000010.18,.08,0)["AUTTCMOD"
SET M=$PIECE(^AUPNVCPT(Y,0),U,8)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+24 IF ^DD(9000010.18,.09,0)["AUTTCMOD"
SET M=$PIECE(^AUPNVCPT(Y,0),U,9)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+25 IF ^DD(9000010.18,.08,0)["DIC(81.3"
SET M=$PIECE(^AUPNVCPT(Y,0),U,8)
IF M
SET M=$PIECE($GET(^DIC(81.3,M,0)),U)
IF M=50
SET %=1
+26 IF ^DD(9000010.18,.09,0)["DIC(81.3"
SET M=$PIECE(^AUPNVCPT(Y,0),U,9)
IF M
SET M=$PIECE($GET(^DIC(81.3,M,0)),U)
IF M=50
SET %=1
+27 IF %
QUIT
End DoDot:2
+28 QUIT
End DoDot:1
IF %]""
QUIT 1
+29 ; now check tran codes
+30 IF T
IF $DATA(^AUPNVTC("AC",P))
SET %=""
Begin DoDot:1
+31 SET E=0
FOR
SET E=$ORDER(^AUPNVTC("AC",P,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+32 SET D=$PIECE($GET(^AUPNVTC(E,0)),U,3)
IF 'D
QUIT
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+33 IF '$$ICD^BGP8UTL2($PIECE(^AUPNVTC(E,0),U,7),T,1)
QUIT
+34 IF D>EDATE
QUIT
+35 SET BGPX(D)=""
+36 IF '$DATA(^DIC(81.3,0))
SET M=$PIECE(^AUPNVTC(E,0),U,12)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+37 IF '$DATA(^DIC(81.3,0))
SET M=$PIECE(^AUPNVTC(E,0),U,15)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+38 IF $DATA(^DIC(81.3,0))
SET M=$PIECE(^AUPNVTC(E,0),U,12)
IF M
SET M=$PIECE($GET(^DIC(81.3,M,0)),U)
IF M=50
SET %=1
+39 IF $DATA(^DIC(81.3,0))
SET M=$PIECE(^AUPNVTC(E,0),U,15)
IF M
SET M=$PIECE($GET(^DIC(81.3,M,0)),U)
IF M=50
SET %=1
+40 IF %
QUIT
+41 SET M=""
+42 QUIT
End DoDot:2
+43 QUIT
End DoDot:1
IF %]""
QUIT 1
+44 ;see if 2 on different dates 14 DAYS APART
+45 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+46 IF C=1
SET Y=X
QUIT
+47 IF $$FMDIFF^XLFDT(X,Y)<14
KILL BGPX(X)
QUIT
+48 SET Y=X
End DoDot:1
+49 ;count
+50 SET C=0
SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+51 IF C>1
QUIT 1
+52 QUIT ""
BLINDPL(P,EDATE) ;EP
+1 NEW X,T,G,R,L,Y,C
+2 SET X=$$PLTAXND^BGP8DU(P,"BGP BILATERAL BLINDNESS DXS",EDATE)
+3 IF X
QUIT 1
+4 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP BILAT BLINDNESS",EDATE)
+5 IF X
QUIT 1
+6 ;CODE WITH LATERALITY=BILATERAL
SET T="PXRM BGP BLINDNESS UNSPECIFIED"
+7 ;LOOP PROBLEM LIST
+8 SET (X,G,R,L)=""
+9 FOR
SET X=$ORDER(^AUPNPROB("APCT",P,X))
IF X=""!(G)
QUIT
Begin DoDot:1
+10 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB("APCT",P,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNPROB(Y,0))
QUIT
+12 ;deleted
IF $PIECE(^AUPNPROB(Y,0),U,12)="D"
QUIT
+13 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,T,X))
QUIT
+14 ;if there is a doo and it is after report period skip
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,13)>EDATE
QUIT
+15 ;no doo, entered after report period, skip
IF $PIECE(^AUPNPROB(Y,0),U,13)=""
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,8)>EDATE
QUIT
+16 ;IS LATERALITY BILATERAL:
+17 SET C=$$VAL^XBDIQ1(9000011,Y,.22)
+18 ;$$CONCPT^AUPNVUTL(X)
IF $$UP^XLFSTR(C)["BILATERAL"
SET G=1_U_"Problem List: "_X
QUIT
+19 IF $$UP^XLFSTR(C)["LEFT"
SET L=1
+20 IF $$UP^XLFSTR(C)["RIGHT"
SET R=1
End DoDot:2
End DoDot:1
+21 IF G
QUIT G
+22 IF R
IF L
QUIT 1_U_"Problem List: "_X
+23 ;NOW CHECK RIGHT AND LEFT SNOMED SUBSETS
+24 NEW TR,TL
+25 IF 'R
Begin DoDot:1
+26 SET TR="PXRM BGP RIGHT EYE BLIND"
+27 ;LOOP PROBLEM LIST
+28 SET (X,G)=""
+29 FOR
SET X=$ORDER(^AUPNPROB("APCT",P,X))
IF X=""!(G)
QUIT
Begin DoDot:2
+30 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB("APCT",P,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+31 IF '$DATA(^AUPNPROB(Y,0))
QUIT
+32 ;deleted
IF $PIECE(^AUPNPROB(Y,0),U,12)="D"
QUIT
+33 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,TR,X))
QUIT
+34 ;if there is a doo and it is after report period skip
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,13)>EDATE
QUIT
+35 ;no doo, entered after report period, skip
IF $PIECE(^AUPNPROB(Y,0),U,13)=""
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,8)>EDATE
QUIT
+36 SET R=1
End DoDot:3
End DoDot:2
End DoDot:1
+37 IF R
IF L
QUIT 1_U_"Problem List: "_X
+38 IF 'L
Begin DoDot:1
+39 SET TL="PXRM BGP LEFT EYE BLIND"
+40 ;LOOP PROBLEM LIST
+41 SET (X,G)=""
+42 FOR
SET X=$ORDER(^AUPNPROB("APCT",P,X))
IF X=""!(G)
QUIT
Begin DoDot:2
+43 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB("APCT",P,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+44 IF '$DATA(^AUPNPROB(Y,0))
QUIT
+45 ;deleted
IF $PIECE(^AUPNPROB(Y,0),U,12)="D"
QUIT
+46 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,TL,X))
QUIT
+47 ;if there is a doo and it is after report period skip
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,13)>EDATE
QUIT
+48 ;no doo, entered after report period, skip
IF $PIECE(^AUPNPROB(Y,0),U,13)=""
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,8)>EDATE
QUIT
+49 SET L=1
End DoDot:3
End DoDot:2
End DoDot:1
+50 IF R
IF L
QUIT 1_U_"Problem List: "_X
+51 QUIT ""
CHDPL(P,EDATE) ;EP - is dx on problem list as either active or inactive?
+1 NEW T,T1,T2,T3,SN1,SN2,SN3,SN4,T4,T5,SN5,SN6,SN7,SN8
+2 SET T=$ORDER(^ATXAX("B","BGP CHD DXS",0))
+3 SET T1=$ORDER(^ATXAX("B","BGP AMI DXS PAMT",0))
+4 SET T2=$ORDER(^ATXAX("B","BGP IVD DXS",0))
+5 SET T3=$ORDER(^ATXAX("B","BGP TIA DXS",0))
+6 SET T4=$ORDER(^ATXAX("B","BGP ARTERIAL DISEASE DXS",0))
+7 SET SN1="PXRM ISCHEMIC HEART DISEASE"
+8 SET SN2="PXRM BGP AMI"
+9 SET SN3="PXRM BGP IVD"
+10 SET SN4="PXRM BGP ISCHEMIC STROKE TIA"
+11 SET SN5="PXRM BGP ARTERIAL DISEASE"
+12 SET SN6="PXRM BGP CABG"
+13 SET SN7="PXRM BGP PCI"
+14 SET SN8="PXRM BGP CAROTID INTERVENTION"
PL ;
+1 NEW X,Y,I,S
+2 SET (X,Y,I)=0
+3 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+4 IF '$DATA(^AUPNPROB(X,0))
QUIT
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+7 SET Y=$PIECE(^AUPNPROB(X,0),U)
+8 ;if there is a doo and it is after report period skip
IF EDATE
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+9 ;no doo, entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF EDATE
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+10 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+11 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN1,S))
SET I=1
QUIT
+12 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN2,S))
SET I=1
QUIT
+13 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN3,S))
SET I=1
QUIT
+14 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN4,S))
SET I=1
QUIT
+15 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN5,S))
SET I=1
QUIT
+16 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN6,S))
SET I=1
QUIT
+17 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN7,S))
SET I=1
QUIT
+18 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN8,S))
SET I=1
QUIT
+19 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP8UTL2(Y,T,9)
SET I=1
QUIT
+20 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP8UTL2(Y,T1,9)
SET I=1
QUIT
+21 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP8UTL2(Y,T2,9)
SET I=1
QUIT
+22 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP8UTL2(Y,T3,9)
SET I=1
QUIT
+23 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP8UTL2(Y,T4,9)
SET I=1
QUIT
+24 QUIT
End DoDot:1
+25 QUIT I
HEPA(P,BDATE,EDATE) ;
+1 ;EP
+2 NEW BGPG,E,Y,X
+3 ;S BDATE=$$DOB^AUPNPAT(P)
+4 KILL BGPG
+5 SET Y="BGPG("
+6 SET X=P_"^LAST DX [BGP HEPATITIS A EVIDENCE;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BGPG(1))
QUIT 1
+8 IF $$PLTAXND^BGP8DU(P,"BGP HEPATITIS A EVIDENCE",EDATE)
QUIT 1
+9 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS A",EDATE)
QUIT 1
+10 QUIT 0
HEPB(P,BDATE,EDATE) ;
+1 ;EP
+2 NEW BGPG,E,Y,X
+3 ;S BDATE=$$DOB^AUPNPAT(P)
+4 KILL BGPG
+5 SET Y="BGPG("
+6 SET X=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BGPG(1))
QUIT 1
+8 IF $$PLTAXND^BGP8DU(P,"BGP HEP EVIDENCE",EDATE)
QUIT 1
+9 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS B",EDATE)
QUIT 1
+10 QUIT 0
