- 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