BGP4D27 ; IHS/CMI/LAB - measure I2 ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
;
AMP(P,EDATE) ;EP - DID PATIENT HAVE AMPUTATION
;
;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 FOOT AMP CPTS",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)
..Q:'$$ICD^BGP4UTL2(X,T,1)
..S BGPX(D)=""
..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^BGP4UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)
..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^BGP4UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)
..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),".")
..Q:'$$ICD^BGP4UTL2($P(^AUPNVTC(E,0),U,7),T,1)
..S Y=$P(^AUPNVTC(E,0),U,7)
..I D>EDATE Q
..S BGPX(D)=""
..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^BGP4UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)
..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^BGP4UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)
..Q
.Q
;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 BGPG=$$LASTPRC^BGP4UTL1(P,"BGP BILAT FOOT AMP PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
I BGPG 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^BGP4UTL2(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
Q 0
BGP4D27 ; IHS/CMI/LAB - measure I2 ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
+3 ;
AMP(P,EDATE) ;EP - DID PATIENT HAVE AMPUTATION
+1 ;
+2 ;check cpt codes for bilateral
+3 ;loop through all cpt codes up to Edate and if any match quit
+4 SET (X,Y,Z,G)=0
KILL BGPX
+5 SET T=$ORDER(^ATXAX("B","BGP FOOT AMP CPTS",0))
+6 IF T
SET %=""
Begin DoDot:1
+7 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AC",P,Y))
IF Y'=+Y!(%]"")
QUIT
Begin DoDot:2
+8 SET D=$PIECE($GET(^AUPNVCPT(Y,0)),U,3)
+9 IF D=""
QUIT
+10 ;date done
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+11 IF D=""
QUIT
+12 IF D>EDATE
QUIT
+13 SET X=$PIECE(^AUPNVCPT(Y,0),U)
+14 IF '$$ICD^BGP4UTL2(X,T,1)
QUIT
+15 SET BGPX(D)=""
+16 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^BGP4UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)
+17 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^BGP4UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
IF %]""
QUIT %
+20 ; now check tran codes
+21 IF T
IF $DATA(^AUPNVTC("AC",P))
SET %=""
Begin DoDot:1
+22 SET E=0
FOR
SET E=$ORDER(^AUPNVTC("AC",P,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+23 SET D=$PIECE($GET(^AUPNVTC(E,0)),U,3)
IF 'D
QUIT
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+24 IF '$$ICD^BGP4UTL2($PIECE(^AUPNVTC(E,0),U,7),T,1)
QUIT
+25 SET Y=$PIECE(^AUPNVTC(E,0),U,7)
+26 IF D>EDATE
QUIT
+27 SET BGPX(D)=""
+28 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^BGP4UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)
+29 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^BGP4UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)
+30 QUIT
End DoDot:2
+31 QUIT
End DoDot:1
IF %]""
QUIT %
+32 ;see if 2 on different dates
+33 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+34 IF C>1
QUIT 1
+35 SET BGPG=$$LASTPRC^BGP4UTL1(P,"BGP BILAT FOOT AMP PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
+36 IF BGPG
QUIT 1
+37 SET T=$ORDER(^ATXAX("B","BGP FOOT AMP PROCEDURES",0))
+38 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
+39 SET G=0
IF $$ICD^BGP4UTL2(C,T,0)
SET G=1
+40 IF G=0
QUIT
+41 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+42 IF D>EDATE
QUIT
+43 SET BGPX(D)=""
End DoDot:1
+44 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+45 IF C>1
QUIT 1
+46 QUIT 0
