- BGP2D27 ; IHS/CMI/LAB - measure I2 ;
- ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- ;
- ;
- 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^ATXCHK(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^BGP2UTL(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^BGP2UTL(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^ATXCHK($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^BGP2UTL(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^BGP2UTL(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 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^ATXCHK(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
- BGP2D27 ; IHS/CMI/LAB - measure I2 ;
- +1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- +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^ATXCHK(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^BGP2UTL(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^BGP2UTL(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^ATXCHK($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^BGP2UTL(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^BGP2UTL(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 T=$ORDER(^ATXAX("B","BGP FOOT AMP PROCEDURES",0))
- +36 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
- +37 SET G=0
- IF $$ICD^ATXCHK(C,T,0)
- SET G=1
- +38 IF G=0
- QUIT
- +39 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
- IF D=""
- SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
- +40 IF D>EDATE
- QUIT
- +41 SET BGPX(D)=""
- End DoDot:1
- +42 SET %=0
- SET X=0
- SET C=0
- FOR
- SET X=$ORDER(BGPX(X))
- IF X'=+X
- QUIT
- SET C=C+1
- +43 IF C>1
- QUIT 1
- +44 QUIT 0
