BGP8D27.m

BGP8D27 ; IHS/CMI/LAB - measure I2 ;

 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 ;

 ;

AMP(P,EDATE) ;EP - DID PATIENT HAVE AMPUTATION

 ;

 NEW X,Y,Z,G,T,Y,D,%,E,BGPX,C,BGPG,BGPRL,T1,M,F,C,R,T2

 ;

 ;v18 PATCH 1 problem list

 S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT BIL",EDATE)

 I X Q 1

 S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP BILAT FOOT AMP PROCEDURES",$$DOB^AUPNPAT(P),EDATE)

 I BGPG Q 1

 S BGPG=$$CPT^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP CPT BILAT FOOT AMP",0)))

 I BGPG Q 1

 ;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,BGPRL

 S T=$O(^ATXAX("B","BGP FOOT AMP CPTS",0))

 S T1=$O(^ATXAX("B","BGP CPT FOOT AMP UNKNOWN SIDE",0))

 I T S %="" D  I %]"" Q %

 .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)

 ..I $$ICD^BGP8UTL2(X,T,1) D

 ...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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)

 ..Q:'$$ICD^BGP8UTL2(X,T1,1)

 ..S BGPRL(D,"UNK")=""

 ..Q

 .Q

 ; now check tran codes

 I T,$D(^AUPNVTC("AC",P)) S %="" D  I %]"" Q %

 .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),".")

 ..I D>EDATE Q

 ..I $$ICD^BGP8UTL2($P(^AUPNVTC(E,0),U,7),T,1) D

 ...S Y=$P(^AUPNVTC(E,0),U,7)

 ...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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)

 ..Q:'$$ICD^BGP8UTL2(X,T1,1)

 ..S BGPRL(D,"UNK")=""

 .Q

 ;NEW STUFF FOR PATCH 1 VERSION 18

 ;A RIGHT AND A LEFT OR 2 DIFFERENT DATES

 ;GET ALL RIGHTS AND LEFTS BY DX/PROC

 K BGPRLU

 ;PROBLEM LIST

 S X=$$PLTAXND^BGP8DU(P,"BGP RIGHT FOOT AMP DXS",EDATE)

 I X S BGPRL($P(X,U,3),"RT")=""

 S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT RIGHT",EDATE)

 I X S BGPRL($P(X,U,3),"RT")=""

 S X=$$PLTAXND^BGP8DU(P,"BGP LEFT FOOT AMP DXS",EDATE)

 I X S BGPRL($P(X,U,3),"LT")=""

 S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT LEFT",EDATE)

 I X S BGPRL($P(X,U,3),"LT")=""

 ;IF THERE IS A RIGHT AND A LEFT STOP NOW

 S G="",D=0,R="",L="" F  S D=$O(BGPRL(D)) Q:D'=+D  D

 .I $D(BGPRL(D,"RT")) S R=D

 .I $D(BGPRL(D,"LT")) S L=D

 I R,L Q 1  ;HAS RIGHT AND LEFT

 S T=$O(^ATXAX("B","BGP RIGHT FOOT AMP PROCS",0))

 S T1=$O(^ATXAX("B","BGP LEFT FOOT AMP PROCS",0))

 S T2=$O(^ATXAX("B","BGP FOOT AMP PROCEDURES",0))

 S (F,S)=0 F  S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F  S C=$P(^AUPNVPRC(F,0),U) D

 .S G=""

 .I $$ICD^BGP8UTL2(C,T,0) S G="RT"

 .I $$ICD^BGP8UTL2(C,T1,0) S G="LT"

 .I $$ICD^BGP8UTL2(C,T2,0) S G="UNK"

 .Q:G=""

 .S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")

 .I D>EDATE Q

 .S BGPRL(D,G)=""

 ;IF THERE IS A RIGHT AND A LEFT STOP NOW

 S G="",D=0,R="",L="" F  S D=$O(BGPRL(D)) Q:D'=+D  D

 .I $D(BGPRL(D,"RT")) S R=D

 .I $D(BGPRL(D,"LT")) S L=D

 I R,L Q 1  ;HAS RIGHT AND LEFT

 ;NOW GET RT DXS

 K BGPG

 S Y="BGPG("

 S X=P_"^ALL DX [BGP RIGHT FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,Y)

 S %=0 F  S %=$O(BGPG(%)) Q:%'=+%  S D=$P(BGPG(%),U,1),BGPRL(D,"RT")=""

 ;NOW GET LEFT DXS

 K BGPG

 S Y="BGPG("

 S X=P_"^ALL DX [BGP LEFT FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,Y)

 S %=0 F  S %=$O(BGPG(%)) Q:%'=+%  S D=$P(BGPG(%),U,1),BGPRL(D,"LT")=""

 ;IF THERE IS A RIGHT AND A LEFT STOP NOW

 S G="",D=0,R="",L="" F  S D=$O(BGPRL(D)) Q:D'=+D  D

 .I $D(BGPRL(D,"RT")) S R=D

 .I $D(BGPRL(D,"LT")) S L=D

 I R,L Q 1  ;HAS RIGHT AND LEFT

 ;GET ALL UNKNOWNS, ALREADY HAVE PROCS AND CPTS

 ;ADD DXS

 ;NOW ADD IN DX CODES

 K BGPG

 S Y="BGPG("

 S X=P_"^ALL DX [BGP UNILATERAL FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,Y)

 S %=0 F  S %=$O(BGPG(%)) Q:%'=+%  S D=$P(BGPG(%),U,1),BGPRL(D,"UNK")=""

 ;

 ;kill off all unknowns on the same day as a right or left

 S D=0 F  S D=$O(BGPRL(D)) Q:D=""  I $D(BGPRL(D,"RT")) K BGPRL(D,"UNK")

 S D=0 F  S D=$O(BGRPL(D)) Q:D=""  I $D(BGPRL(D,"LT")) K BGPRL(D,"UNK")

 ;is there

 S G=0 S D=0 F  S D=$O(BGPRL(D)) Q:D=""!(G)  D

 .Q:'$D(BGPRL(D,"UNK"))

 .S X=0 F  S X=$O(BGPRL(X)) Q:X'=+X  D

 ..Q:X=D

 ..S G=1

 Q G

 ;see if 2 on different dates

 S %=0,X=0,C=0 F  S X=$O(BGPX(X)) Q:X'=+X  S C=C+1

 I C>1 Q 1

 S T=$O(^ATXAX("B","BGP FOOT AMP PROCEDURES",0))

 S (F,S)=0 F  S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F  S C=$P(^AUPNVPRC(F,0),U) D

 .S G=0 S:$$ICD^BGP8UTL2(C,T,0) G=1

 .Q:G=0

 .S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")

 .I D>EDATE Q

 .S BGPX(D)=""

 S %=0,X=0,C=0 F  S X=$O(BGPX(X)) Q:X'=+X  S C=C+1

 I C>1 Q 1

 ;NOW ADD IN DX CODES

 K BGPG

 S Y="BGPG("

 S X=P_"^ALL DX [BGP UNILATERAL FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,Y)

 S %=0 F  S %=$O(BGPG(%)) Q:%'=+%  S D=$P(BGPG(%),U,1),BGPX(D)=""

 S %=0,X=0,C=0 F  S X=$O(BGPX(X)) Q:X'=+X  S C=C+1

 I C>1 Q 1

 Q 0

DEPSCRBH(P,BDATE,EDATE) ;EP

 NEW BGPDEPS,BGPG,%,E,Y,X,BGPC,D,V,BGPP,BGPTC

 S BGPDEPS=""

 I $G(P)="" Q ""

 S BGPTC=$O(^BGPCTRL("B",2018,0))

BH S D=0,BGPC="",E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC)  D

 .Q:'$D(^AMHREC(V,0))

 .S C=$P(^AMHREC(V,0),U,25)

 .Q:'C

 .S C=$P($G(^DIC(40.7,C,0)),U,2)

 .Q:C=""

 .Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic

 .I $P($G(^AMHREC(V,14)),U,5)="P"!($P($G(^AMHREC(V,14)),U,5)="N") S BGPC=1_U_C_U_$$DATE^BGP8UTL(9999999-D)_U_(9999999-D)_U_C

 .Q:BGPC

 .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC)  S BGPP=$P($G(^AMHRPRO(X,0)),U) D

 ..Q:'BGPP

 ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)

 ..I BGPP=14.1 S BGPC=1_U_C_U_$$DATE^BGP8UTL(9999999-D)_U_(9999999-D)_U_C Q

 .Q:BGPC

 .S X=0 F  S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(BGPC)  S BGPP=$P($G(^AMHRMSR(X,0)),U) D

 ..Q:'BGPP

 ..S BGPP=$P($G(^AUTTMSR(BGPP,0)),U)

 ..I BGPP="PHQ2"!(BGPP="PHQ9")!(BGPP="PHQT") S BGPC=1_U_C_U_$$DATE^BGP8UTL(9999999-D)_U_(9999999-D)_U_C

 .Q:BGPC

 .S X=0 F  S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(BGPC)  S BGPP=$P($G(^AMHRPROC(X,0)),U) D

 ..Q:'BGPP

 ..Q:'$$ICD^BGP8UTL2(BGPP,$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1)

 ..S BGPC=1_U_C_U_$$DATE^BGP8UTL(9999999-D)_U_(9999999-D)_U_C

 I BGPC]"",$P(BGPDEPS,U,4)<$P(BGPC,U,4) S BGPDEPS=BGPC

 K BGPG S %=P_"^ALL EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) D

 .S E=0 F  S E=$O(BGPG(E)) Q:E'=+E  S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D

 ..Q:C=""

 ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic

 ..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_"^"_C_U_$$DATE^BGP8UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C

 K BGPG

 S Y="BGPG("

 S X=P_"^ALL DX [BGP DEPRESSION SCRN DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) D

 .S E=0 F  S E=$O(BGPG(E)) Q:E'=+E  S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D

 ..Q:C=""

 ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic

 ..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_"^"_C_U_$$DATE^BGP8UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C

 ;now add in v measurements

 K BGPG

 S Y="BGPG("

 S X=P_"^ALL MEAS PHQ2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) D

 .S E=0 F  S E=$O(BGPG(E)) Q:E'=+E  S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D

 ..Q:C=""

 ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic

 ..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_C_U_$$DATE^BGP8UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C

 K BGPG

 S Y="BGPG("

 S X=P_"^ALL MEAS PHQ9;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) D

 .S E=0 F  S E=$O(BGPG(E)) Q:E'=+E  S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D

 ..Q:C=""

 ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic

 ..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_C_U_$$DATE^BGP8UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C

 K BGPG

 S Y="BGPG("

 S X=P_"^ALL MEAS PHQT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) D

 .S E=0 F  S E=$O(BGPG(E)) Q:E'=+E  S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D

 ..Q:C=""

 ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic

 ..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_C_U_$$DATE^BGP8UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C

BHSCRC ;

 ;go through visits in a date range for this patient, check cpts

 NEW BD,ED

 S ED=(9999999-EDATE),BD=9999999-BDATE,G=""

 F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G)  D

 .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G)  D

 ..Q:'$D(^AUPNVSIT(V,0))

 ..Q:'$D(^AUPNVCPT("AD",V))

 ..S C=$$CLINIC^APCLV(V,"C")

 ..Q:C=""

 ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))

 ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G)  D

 ...I $$ICD^BGP8UTL2($P(^AUPNVCPT(X,0),U),$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1) S G=1_U_C_U_$$DATE^BGP8UTL($$VD^APCLV(V))_U_$$VD^APCLV(V)_U_C

 ...Q

 ..Q

 .Q

 I G,$P(BGPDEPS,U,4)<$P(G,U,1) S BGPDEPS=G

 Q BGPDEPS

BGP8D27   ; IHS/CMI/LAB - measure I2 ;

 +1       ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 +2       ;

 +3       ;

AMP(P,EDATE) ;EP - DID PATIENT HAVE AMPUTATION

 +1       ;

 +2        NEW X,Y,Z,G,T,Y,D,%,E,BGPX,C,BGPG,BGPRL,T1,M,F,C,R,T2

 +3       ;

 +4       ;v18 PATCH 1 problem list

 +5        SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT BIL",EDATE)

 +6        IF X

               QUIT 1

 +7        SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP BILAT FOOT AMP PROCEDURES",$$DOB^AUPNPAT(P),EDATE)

 +8        IF BGPG

               QUIT 1

 +9        SET BGPG=$$CPT^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP CPT BILAT FOOT AMP",0)))

 +10       IF BGPG

               QUIT 1

 +11      ;check cpt codes for bilateral

 +12      ;loop through all cpt codes up to Edate and if any match quit

 +13       SET (X,Y,Z,G)=0

           KILL BGPX,BGPRL

 +14       SET T=$ORDER(^ATXAX("B","BGP FOOT AMP CPTS",0))

 +15       SET T1=$ORDER(^ATXAX("B","BGP CPT FOOT AMP UNKNOWN SIDE",0))

 +16       IF T

               SET %=""

               Begin DoDot:1

 +17               SET Y=0

                   FOR 

                       SET Y=$ORDER(^AUPNVCPT("AC",P,Y))

                       IF Y'=+Y!(%]"")

                           QUIT 

                       Begin DoDot:2

 +18                       SET D=$PIECE($GET(^AUPNVCPT(Y,0)),U,3)

 +19                       IF D=""

                               QUIT 

 +20      ;date done

                           SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +21                       IF D=""

                               QUIT 

 +22                       IF D>EDATE

                               QUIT 

 +23                       SET X=$PIECE(^AUPNVCPT(Y,0),U)

 +24                       IF $$ICD^BGP8UTL2(X,T,1)

                               Begin DoDot:3

 +25                               SET BGPX(D)=""

 +26      ;

 +27                               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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)

 +28                               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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)

 +29                               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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)

 +30                               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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)

                               End DoDot:3

 +31                       IF '$$ICD^BGP8UTL2(X,T1,1)

                               QUIT 

 +32                       SET BGPRL(D,"UNK")=""

 +33                       QUIT 

                       End DoDot:2

 +34               QUIT 

               End DoDot:1

               IF %]""

                   QUIT %

 +35      ; now check tran codes

 +36       IF T

               IF $DATA(^AUPNVTC("AC",P))

                   SET %=""

                   Begin DoDot:1

 +37                   SET E=0

                       FOR 

                           SET E=$ORDER(^AUPNVTC("AC",P,E))

                           IF E'=+E!(%]"")

                               QUIT 

                           Begin DoDot:2

 +38                           SET D=$PIECE($GET(^AUPNVTC(E,0)),U,3)

                               IF 'D

                                   QUIT 

                               SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +39                           IF D>EDATE

                                   QUIT 

 +40                           IF $$ICD^BGP8UTL2($PIECE(^AUPNVTC(E,0),U,7),T,1)

                                   Begin DoDot:3

 +41                                   SET Y=$PIECE(^AUPNVTC(E,0),U,7)

 +42                                   SET BGPX(D)=""

 +43                                   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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)

 +44                                   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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)

 +45                                   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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)

 +46                                   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_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)

                                   End DoDot:3

 +47                           IF '$$ICD^BGP8UTL2(X,T1,1)

                                   QUIT 

 +48                           SET BGPRL(D,"UNK")=""

                           End DoDot:2

 +49                   QUIT 

                   End DoDot:1

                   IF %]""

                       QUIT %

 +50      ;NEW STUFF FOR PATCH 1 VERSION 18

 +51      ;A RIGHT AND A LEFT OR 2 DIFFERENT DATES

 +52      ;GET ALL RIGHTS AND LEFTS BY DX/PROC

 +53       KILL BGPRLU

 +54      ;PROBLEM LIST

 +55       SET X=$$PLTAXND^BGP8DU(P,"BGP RIGHT FOOT AMP DXS",EDATE)

 +56       IF X

               SET BGPRL($PIECE(X,U,3),"RT")=""

 +57       SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT RIGHT",EDATE)

 +58       IF X

               SET BGPRL($PIECE(X,U,3),"RT")=""

 +59       SET X=$$PLTAXND^BGP8DU(P,"BGP LEFT FOOT AMP DXS",EDATE)

 +60       IF X

               SET BGPRL($PIECE(X,U,3),"LT")=""

 +61       SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT LEFT",EDATE)

 +62       IF X

               SET BGPRL($PIECE(X,U,3),"LT")=""

 +63      ;IF THERE IS A RIGHT AND A LEFT STOP NOW

 +64       SET G=""

           SET D=0

           SET R=""

           SET L=""

           FOR 

               SET D=$ORDER(BGPRL(D))

               IF D'=+D

                   QUIT 

               Begin DoDot:1

 +65               IF $DATA(BGPRL(D,"RT"))

                       SET R=D

 +66               IF $DATA(BGPRL(D,"LT"))

                       SET L=D

               End DoDot:1

 +67      ;HAS RIGHT AND LEFT

           IF R

               IF L

                   QUIT 1

 +68       SET T=$ORDER(^ATXAX("B","BGP RIGHT FOOT AMP PROCS",0))

 +69       SET T1=$ORDER(^ATXAX("B","BGP LEFT FOOT AMP PROCS",0))

 +70       SET T2=$ORDER(^ATXAX("B","BGP FOOT AMP PROCEDURES",0))

 +71       SET (F,S)=0

           FOR 

               SET F=$ORDER(^AUPNVPRC("AC",P,F))

               IF F'=+F

                   QUIT 

               SET C=$PIECE(^AUPNVPRC(F,0),U)

               Begin DoDot:1

 +72               SET G=""

 +73               IF $$ICD^BGP8UTL2(C,T,0)

                       SET G="RT"

 +74               IF $$ICD^BGP8UTL2(C,T1,0)

                       SET G="LT"

 +75               IF $$ICD^BGP8UTL2(C,T2,0)

                       SET G="UNK"

 +76               IF G=""

                       QUIT 

 +77               SET D=$PIECE(^AUPNVPRC(F,0),U,6)

                   IF D=""

                       SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")

 +78               IF D>EDATE

                       QUIT 

 +79               SET BGPRL(D,G)=""

               End DoDot:1

 +80      ;IF THERE IS A RIGHT AND A LEFT STOP NOW

 +81       SET G=""

           SET D=0

           SET R=""

           SET L=""

           FOR 

               SET D=$ORDER(BGPRL(D))

               IF D'=+D

                   QUIT 

               Begin DoDot:1

 +82               IF $DATA(BGPRL(D,"RT"))