ACHSTX7A ; IHS/ITSC/JVK - EXPORT DATA (8A/9) - RECORD 7(638 STATISTICAL DATA FOR DDPS) ; JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11,14,15,23**;JUN 11,2001;Build 43
;ITSC/SET/JVK ACHS*3.1*11 ADD ADDITIONAL FIELDS FOR EXPORT
;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
;3.1*15 3.4.2009 IHS/OIT/FCJ ADDED CSV CHANGES FOR CPT CODE
;
DXPX ;EP - ITSC/SET/JVK ACHS*3.1*11 INCREASED FOR LOOP FROM 5 TO 9 ENTRIES
S (ACHSAPC(1),ACHSAPC(2))=" ",ACHS=0
I DT<$$PARM^ACHS(0,18) F ACHSX=1:1:9 S ACHSDX(ACHSX)=" ",ACHSPX(ACHSX)=" "
E F ACHSX=1:1:9 S ACHSDX(ACHSX)=" ",ACHSPX(ACHSX)=" "
;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
;F ACHSX=1:1:9 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHS)) Q:'ACHS S ACHSDX(ACHSX)=$P(^ICD9(+^(ACHS,0),0),U) S:ACHSDX(ACHSX)["." ACHSDX(ACHSX)=$P(ACHSDX(ACHSX),".")_$P(ACHSDX(ACHSX),".",2) S ACHSDX(ACHSX)=$E(ACHSDX(ACHSX)_" ",1,5)
;ACHS*3.1*23 SPLIT NEXT LINE TO TEST FOR ICD-10 DATE
F ACHSX=1:1:9 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHS)) Q:'ACHS D
.;S ACHSDX(ACHSX)=$P($$ICDDX^ICDCODE($P(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHS,0),U)),U,2) ;ACHS*3.1*23
.S ACHSDX(ACHSX)=$P($$ICDDX^ICDEX($P(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHS,0),U)),U,2) ;ACHS*3.1*23
.I DT<$$PARM^ACHS(0,18) S:ACHSDX(ACHSX)["." ACHSDX(ACHSX)=$P(ACHSDX(ACHSX),".")_$P(ACHSDX(ACHSX),".",2) S ACHSDX(ACHSX)=$E(ACHSDX(ACHSX)_" ",1,5)
.E S ACHSDX(ACHSX)=$E(ACHSDX(ACHSX)_" ",1,8)
S ACHS=0
;3.1*15 3.4.2009 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES, LINE WAS TOO LONG, ALSO CHGD LOOP VAR
;F ACHSX=1:1:3 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHS)) Q:'ACHS S ACHSPX(ACHSX)=$P(^ICD0(+^(ACHS,0),0),U) S:ACHSPX(ACHSX)["." ACHSPX(ACHSX)=$P(ACHSPX(ACHSX),".")_$P(ACHSPX(ACHSX),".",2) S ACHSPX(ACHSX)=$E(ACHSPX(ACHSX)_" ",1,4)
;ACHS*3.1*23 MODS FOR ICD10
;F X=1:1:3 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHS)) Q:'ACHS S ACHSPX(X)=$P($$ICDOP^ICDCODE(+^(ACHS,0)),U,2) S:ACHSPX(X)["." ACHSPX(X)=$P(ACHSPX(X),".")_$P(ACHSPX(X),".",2) S ACHSPX(X)=$E(ACHSPX(X)_" ",1,4)
F X=1:1:3 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHS)) Q:'ACHS D
.;S ACHSPX(X)=$P($$ICDOP^ICDCODE(+^(ACHS,0)),U,2) ;ACHS*3.1*23
.S ACHSPX(X)=$P($$ICDOP^ICDEX($P(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHS,0),U),,,"I"),U,2) ;ACHS*3.1*23
.I DT<$$PARM^ACHS(0,18) S:ACHSPX(X)["." ACHSPX(X)=$P(ACHSPX(X),".")_$P(ACHSPX(X),".",2) S ACHSPX(X)=$E(ACHSPX(X)_" ",1,4)
.E S ACHSPX(X)=$E(ACHSPX(X)_" ",1,7)
F ACHS=1,2 S ACHSY=ACHSDX(ACHS) I ACHSY]" " D RECODE S ACHSAPC(ACHS)=ACHS("AC")
Q
;
RECODE ; Code copied from APCPAPOV. Look up the RECODE APC/ICD value.
S ACHS("AC")=" ",ACHS("ICD")=ACHSDX(ACHS)
; Weed out etiology codes
I $E(ACHSY)="E" Q
I $E(ACHSY)="." S ACHS("ICD")="10"_$P(ACHS("ICD"),".",2)_" ",ACHSY="10"_ACHSY,ACHSY=ACHSY-.000001,ACHSY=$P(ACHSY,".")_$P(ACHSY,".",2)_" " G HIGH
S ACHS("ICD")="09"_($P(ACHS("ICD"),".")_$P(ACHS("ICD"),".",2))_" "
I $E(ACHSY)="V" S ACHSY=(9_$E(ACHSY,2,9999)-.000001),ACHSY="09V"_$E(ACHSY,2,9999),ACHSY=$P(ACHSY,".")_$P(ACHSY,".",2)_" " G HIGH
S ACHSY="09"_ACHSY-.000001,ACHSY="0"_($P(ACHSY,".")_$P(ACHSY,".",2))_" "
HIGH ;
S ACHS("HIGH")=$O(^AUTTRCD("AH",ACHSY))
I ACHS("HIGH")="" S ACHS("AC")=999 Q
S ACHS("DA1")=$O(^AUTTRCD("AH",ACHS("HIGH"),""))
I ACHS("DA1")="" Q ; Error in Recode x-ref
S ACHS("DA2")=$O(^AUTTRCD("AH",ACHS("HIGH"),ACHS("DA1"),"")),ACHS("LOW")=$P(^AUTTRCD(ACHS("DA1"),11,ACHS("DA2"),0),U)_" "
I ACHS("LOW")]ACHS("ICD") S ACHS("AC")=999 Q
S ACHS("AC")=$P(^AUTTRCD(ACHS("DA1"),0),U)
Q
;
TYPE(D) ;EP - D=DFN in ^AUPNPAT. Return "I" if Indian, else "O"
I $L($P($G(^AUPNPAT(D,0)),U,7)) Q "I" ; Tribal Enrollment Number
I $P($G(^AUPNPAT(D,11)),U,8) Q "I" ; Tribe of Membership
I $L($P($G(^AUPNPAT(D,11)),U,9)) Q "I" ; Tribe Quantum
I $L($P($G(^AUPNPAT(D,11)),U,10)) Q "I" ; Indian Quantum
S %=$P($G(^AUPNPAT(D,11)),U,11)
I %,$P($G(^AUTTBEN(%,0)),U,2)="01" Q "I" ; Beneficiary is "01"
Q "O"
;
AGE(Y) ;EP - Y=DFN in ^AUPNPAT. Return age of pt in 2 digit numeric string.
N ACHSAGE
S ACHSAGE=$$AGE^AUPNPAT(Y)
Q $E(ACHSAGE,$L(ACHSAGE)-1,$L(ACHSAGE))
;
INS(ACHSR) ;EP ACHSR=DFN in ^AUPNPAT. Return if pt has MCaid, MCare, Pvt ins.
N ACHS3C,ACHS3CFL,ACHSDEST,ACHSDOCR,ACHSINSR,ACHSMCD,ACHSTRAN,DA
S ACHS3CFL=0,ACHSDEST=""
D ^ACHSTX3C
N A,B,C
S (A,B,C)=" "
F %=1:1 Q:'$D(ACHS3C(%)) D
.I $E(ACHS3C(%),3,10)="MEDICAID" S A="Y" Q
.I $E(ACHS3C(%),3,10)="MEDICARE" S B="Y" Q
.S C="Y"
.Q
Q A_B_C
;
ZIP(D) ;EP - D=DFN in ^DPT. Return Zip code of pt.
S %=$P($G(^DPT(D,.11)),U,6),%=$P(%,"-")_$P(%,"-",2),%="000000000"_%
Q $E(%,$L(%)-8,$L(%))
;
ADA(F,D) ;EP - F=DUZ(2), D=Document EIN. Return ADA codes, fee, and units.
;
; B = ADA Codes (15)
; E = Total Fee Charged ($$$$$cc)
; C = ADA Units (15)
;
N A,B,C,E
S (B,C)="",E=0
F %=0:0 S %=$O(^ACHSF(F,"D",D,11,%)) Q:'% S A=^(%,0) I $P($P(A,U),";",2)="AUTTADA(" S X=$P($G(^AUTTADA(+A,0)),U),B=B_$S($L(X)=4:X,1:" "),X="0000"_$P(A,U,4),X=$E(X,$L(X)-3,$L(X)),C=C_$S(+X:X,1:" "),E=E+$P(A,U,6)
S B=$E(B_$J("",60),1,60),C=$E(C_$J("",60),1,60)
S X="00000"_$P(E,"."),X=$E(X,$L(X)-4,$L(X))
S Y="00"_$P(E,".",2),Y=$E(Y,$L(Y)-1,$L(Y))
S E=X_Y
Q B_U_E_U_C
;
CPT(F,D) ;EP- ITSC/SET/JVK ACHS*3.1*11 ADDED FOR EXPORT OF CPT
; F=DUZ(2), D=Document EIN. Return CPT codes, fee, and units.
;
; B = CPT Codes (25)
; E = Total Unit Fee Charged (25) ($$$$$cc)
; C = CPT Units (25)
;
N A,B,C,E
S (B,C,E)=""
F %=0:0 S %=$O(^ACHSF(F,"D",D,11,%)) Q:'% S A=^(%,0) I $P($P(A,U),";",2)="ICPT(" S X=$P($G(^ICPT(+A,0)),U),B=B_$S($L(X)=5:X,1:" "),X="00000"_$P(A,U,4),X=$E(X,$L(X)-3,$L(X)),C=C_$S(+X:X,1:" "),J=$P(A,U,6)
S X="00000"_$P(J,"."),X=$E(X,$L(X)-4,$L(X)),Y="00"_$P(J,".",2),Y=$E(Y,$L(Y)-1,$L(Y)),J=X_Y,E=E_J
S B=$E(B_$J("",125),1,125),C=$E(C_$J("",100),1,100),E=$E(E_$J("",175),1,175)
Q B_U_E_U_C
;
REV(F,D) ;EP - ITSC/SET/JVK ACHS*3.1*11 ADDED FOR EXPORT OF REV
; F=DUZ(2), D=Document EIN. Return REV codes, fee, and units.
;
; B = REV Codes (25)
; E = Total Unit Fee Charged (25)($$$$$cc)
; C = REV Units (25)
;
N A,B,C,E
S (B,C,E)=""
F %=0:0 S %=$O(^ACHSF(F,"D",D,11,%)) Q:'% S A=^(%,0) I $P($P(A,U),";",2)="AUTTREVN(" S X=$P($G(^AUTTREVN(+A,0)),U),B=B_$S($L(X)=3:X,1:" "),X="000"_$P(A,U,4),X=$E(X,$L(X)-3,$L(X)),C=C_$S(+X:X,1:" "),J=$P(A,U,6)
S X="00000"_$P(J,"."),X=$E(X,$L(X)-4,$L(X)),Y="00"_$P(J,".",2),Y=$E(Y,$L(Y)-1,$L(Y)),J=X_Y,E=E_J
S B=$E(B_$J("",75),1,75),C=$E(C_$J("",100),1,100),E=$E(E_$J("",175),1,175)
Q B_U_E_U_C
;
ACHSTX7A ; IHS/ITSC/JVK - EXPORT DATA (8A/9) - RECORD 7(638 STATISTICAL DATA FOR DDPS) ; JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11,14,15,23**;JUN 11,2001;Build 43
+2 ;ITSC/SET/JVK ACHS*3.1*11 ADD ADDITIONAL FIELDS FOR EXPORT
+3 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+4 ;3.1*15 3.4.2009 IHS/OIT/FCJ ADDED CSV CHANGES FOR CPT CODE
+5 ;
DXPX ;EP - ITSC/SET/JVK ACHS*3.1*11 INCREASED FOR LOOP FROM 5 TO 9 ENTRIES
+1 SET (ACHSAPC(1),ACHSAPC(2))=" "
SET ACHS=0
+2 IF DT<$$PARM^ACHS(0,18)
FOR ACHSX=1:1:9
SET ACHSDX(ACHSX)=" "
SET ACHSPX(ACHSX)=" "
+3 IF '$TEST
FOR ACHSX=1:1:9
SET ACHSDX(ACHSX)=" "
SET ACHSPX(ACHSX)=" "
+4 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
+5 ;F ACHSX=1:1:9 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHS)) Q:'ACHS S ACHSDX(ACHSX)=$P(^ICD9(+^(ACHS,0),0),U) S:ACHSDX(ACHSX)["." ACHSDX(ACHSX)=$P(ACHSDX(ACHSX),".")_$P(ACHSDX(ACHSX),".",2) S ACHSDX(ACHSX)=$E(ACHSDX(ACHSX)_" ",1,5)
+6 ;ACHS*3.1*23 SPLIT NEXT LINE TO TEST FOR ICD-10 DATE
+7 FOR ACHSX=1:1:9
SET ACHS=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHS))
IF 'ACHS
QUIT
Begin DoDot:1
+8 ;S ACHSDX(ACHSX)=$P($$ICDDX^ICDCODE($P(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHS,0),U)),U,2) ;ACHS*3.1*23
+9 ;ACHS*3.1*23
SET ACHSDX(ACHSX)=$PIECE($$ICDDX^ICDEX($PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHS,0),U)),U,2)
+10 IF DT<$$PARM^ACHS(0,18)
IF ACHSDX(ACHSX)["."
SET ACHSDX(ACHSX)=$PIECE(ACHSDX(ACHSX),".")_$PIECE(ACHSDX(ACHSX),".",2)
SET ACHSDX(ACHSX)=$EXTRACT(ACHSDX(ACHSX)_" ",1,5)
+11 IF '$TEST
SET ACHSDX(ACHSX)=$EXTRACT(ACHSDX(ACHSX)_" ",1,8)
End DoDot:1
+12 SET ACHS=0
+13 ;3.1*15 3.4.2009 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES, LINE WAS TOO LONG, ALSO CHGD LOOP VAR
+14 ;F ACHSX=1:1:3 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHS)) Q:'ACHS S ACHSPX(ACHSX)=$P(^ICD0(+^(ACHS,0),0),U) S:ACHSPX(ACHSX)["." ACHSPX(ACHSX)=$P(ACHSPX(ACHSX),".")_$P(ACHSPX(ACHSX),".",2) S ACHSPX(ACHSX)=$E(ACHSPX(ACHSX)_" ",1,4)
+15 ;ACHS*3.1*23 MODS FOR ICD10
+16 ;F X=1:1:3 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHS)) Q:'ACHS S ACHSPX(X)=$P($$ICDOP^ICDCODE(+^(ACHS,0)),U,2) S:ACHSPX(X)["." ACHSPX(X)=$P(ACHSPX(X),".")_$P(ACHSPX(X),".",2) S ACHSPX(X)=$E(ACHSPX(X)_" ",1,4)
+17 FOR X=1:1:3
SET ACHS=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHS))
IF 'ACHS
QUIT
Begin DoDot:1
+18 ;S ACHSPX(X)=$P($$ICDOP^ICDCODE(+^(ACHS,0)),U,2) ;ACHS*3.1*23
+19 ;ACHS*3.1*23
SET ACHSPX(X)=$PIECE($$ICDOP^ICDEX($PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHS,0),U),,,"I"),U,2)
+20 IF DT<$$PARM^ACHS(0,18)
IF ACHSPX(X)["."
SET ACHSPX(X)=$PIECE(ACHSPX(X),".")_$PIECE(ACHSPX(X),".",2)
SET ACHSPX(X)=$EXTRACT(ACHSPX(X)_" ",1,4)
+21 IF '$TEST
SET ACHSPX(X)=$EXTRACT(ACHSPX(X)_" ",1,7)
End DoDot:1
+22 FOR ACHS=1,2
SET ACHSY=ACHSDX(ACHS)
IF ACHSY]" "
DO RECODE
SET ACHSAPC(ACHS)=ACHS("AC")
+23 QUIT
+24 ;
RECODE ; Code copied from APCPAPOV. Look up the RECODE APC/ICD value.
+1 SET ACHS("AC")=" "
SET ACHS("ICD")=ACHSDX(ACHS)
+2 ; Weed out etiology codes
+3 IF $EXTRACT(ACHSY)="E"
QUIT
+4 IF $EXTRACT(ACHSY)="."
SET ACHS("ICD")="10"_$PIECE(ACHS("ICD"),".",2)_" "
SET ACHSY="10"_ACHSY
SET ACHSY=ACHSY-.000001
SET ACHSY=$PIECE(ACHSY,".")_$PIECE(ACHSY,".",2)_" "
GOTO HIGH
+5 SET ACHS("ICD")="09"_($PIECE(ACHS("ICD"),".")_$PIECE(ACHS("ICD"),".",2))_" "
+6 IF $EXTRACT(ACHSY)="V"
SET ACHSY=(9_$EXTRACT(ACHSY,2,9999)-.000001)
SET ACHSY="09V"_$EXTRACT(ACHSY,2,9999)
SET ACHSY=$PIECE(ACHSY,".")_$PIECE(ACHSY,".",2)_" "
GOTO HIGH
+7 SET ACHSY="09"_ACHSY-.000001
SET ACHSY="0"_($PIECE(ACHSY,".")_$PIECE(ACHSY,".",2))_" "
HIGH ;
+1 SET ACHS("HIGH")=$ORDER(^AUTTRCD("AH",ACHSY))
+2 IF ACHS("HIGH")=""
SET ACHS("AC")=999
QUIT
+3 SET ACHS("DA1")=$ORDER(^AUTTRCD("AH",ACHS("HIGH"),""))
+4 ; Error in Recode x-ref
IF ACHS("DA1")=""
QUIT
+5 SET ACHS("DA2")=$ORDER(^AUTTRCD("AH",ACHS("HIGH"),ACHS("DA1"),""))
SET ACHS("LOW")=$PIECE(^AUTTRCD(ACHS("DA1"),11,ACHS("DA2"),0),U)_" "
+6 IF ACHS("LOW")]ACHS("ICD")
SET ACHS("AC")=999
QUIT
+7 SET ACHS("AC")=$PIECE(^AUTTRCD(ACHS("DA1"),0),U)
+8 QUIT
+9 ;
TYPE(D) ;EP - D=DFN in ^AUPNPAT. Return "I" if Indian, else "O"
+1 ; Tribal Enrollment Number
IF $LENGTH($PIECE($GET(^AUPNPAT(D,0)),U,7))
QUIT "I"
+2 ; Tribe of Membership
IF $PIECE($GET(^AUPNPAT(D,11)),U,8)
QUIT "I"
+3 ; Tribe Quantum
IF $LENGTH($PIECE($GET(^AUPNPAT(D,11)),U,9))
QUIT "I"
+4 ; Indian Quantum
IF $LENGTH($PIECE($GET(^AUPNPAT(D,11)),U,10))
QUIT "I"
+5 SET %=$PIECE($GET(^AUPNPAT(D,11)),U,11)
+6 ; Beneficiary is "01"
IF %
IF $PIECE($GET(^AUTTBEN(%,0)),U,2)="01"
QUIT "I"
+7 QUIT "O"
+8 ;
AGE(Y) ;EP - Y=DFN in ^AUPNPAT. Return age of pt in 2 digit numeric string.
+1 NEW ACHSAGE
+2 SET ACHSAGE=$$AGE^AUPNPAT(Y)
+3 QUIT $EXTRACT(ACHSAGE,$LENGTH(ACHSAGE)-1,$LENGTH(ACHSAGE))
+4 ;
INS(ACHSR) ;EP ACHSR=DFN in ^AUPNPAT. Return if pt has MCaid, MCare, Pvt ins.
+1 NEW ACHS3C,ACHS3CFL,ACHSDEST,ACHSDOCR,ACHSINSR,ACHSMCD,ACHSTRAN,DA
+2 SET ACHS3CFL=0
SET ACHSDEST=""
+3 DO ^ACHSTX3C
+4 NEW A,B,C
+5 SET (A,B,C)=" "
+6 FOR %=1:1
IF '$DATA(ACHS3C(%))
QUIT
Begin DoDot:1
+7 IF $EXTRACT(ACHS3C(%),3,10)="MEDICAID"
SET A="Y"
QUIT
+8 IF $EXTRACT(ACHS3C(%),3,10)="MEDICARE"
SET B="Y"
QUIT
+9 SET C="Y"
+10 QUIT
End DoDot:1
+11 QUIT A_B_C
+12 ;
ZIP(D) ;EP - D=DFN in ^DPT. Return Zip code of pt.
+1 SET %=$PIECE($GET(^DPT(D,.11)),U,6)
SET %=$PIECE(%,"-")_$PIECE(%,"-",2)
SET %="000000000"_%
+2 QUIT $EXTRACT(%,$LENGTH(%)-8,$LENGTH(%))
+3 ;
ADA(F,D) ;EP - F=DUZ(2), D=Document EIN. Return ADA codes, fee, and units.
+1 ;
+2 ; B = ADA Codes (15)
+3 ; E = Total Fee Charged ($$$$$cc)
+4 ; C = ADA Units (15)
+5 ;
+6 NEW A,B,C,E
+7 SET (B,C)=""
SET E=0
+8 FOR %=0:0
SET %=$ORDER(^ACHSF(F,"D",D,11,%))
IF '%
QUIT
SET A=^(%,0)
IF $PIECE($PIECE(A,U),";",2)="AUTTADA("
SET X=$PIECE($GET(^AUTTADA(+A,0)),U)
SET B=B_$SELECT($LENGTH(X)=4:X,1:" ")
SET X="0000"_$PIECE(A,U,4)
SET X=$EXTRACT(X,$LENGTH(X)-3,$LENGTH(X))
SET C=C_$SELECT(+X:X,1:" ")
SET E=E+$PIECE(A,U,6)
+9 SET B=$EXTRACT(B_$JUSTIFY("",60),1,60)
SET C=$EXTRACT(C_$JUSTIFY("",60),1,60)
+10 SET X="00000"_$PIECE(E,".")
SET X=$EXTRACT(X,$LENGTH(X)-4,$LENGTH(X))
+11 SET Y="00"_$PIECE(E,".",2)
SET Y=$EXTRACT(Y,$LENGTH(Y)-1,$LENGTH(Y))
+12 SET E=X_Y
+13 QUIT B_U_E_U_C
+14 ;
CPT(F,D) ;EP- ITSC/SET/JVK ACHS*3.1*11 ADDED FOR EXPORT OF CPT
+1 ; F=DUZ(2), D=Document EIN. Return CPT codes, fee, and units.
+2 ;
+3 ; B = CPT Codes (25)
+4 ; E = Total Unit Fee Charged (25) ($$$$$cc)
+5 ; C = CPT Units (25)
+6 ;
+7 NEW A,B,C,E
+8 SET (B,C,E)=""
+9 FOR %=0:0
SET %=$ORDER(^ACHSF(F,"D",D,11,%))
IF '%
QUIT
SET A=^(%,0)
IF $PIECE($PIECE(A,U),";",2)="ICPT("
SET X=$PIECE($GET(^ICPT(+A,0)),U)
SET B=B_$SELECT($LENGTH(X)=5:X,1:" ")
SET X="00000"_$PIECE(A,U,4)
SET X=$EXTRACT(X,$LENGTH(X)-3,$LENGTH(X))
SET C=C_$SELECT(+X:X,1:" ")
SET J=$PIECE(A,U,6)
+10 SET X="00000"_$PIECE(J,".")
SET X=$EXTRACT(X,$LENGTH(X)-4,$LENGTH(X))
SET Y="00"_$PIECE(J,".",2)
SET Y=$EXTRACT(Y,$LENGTH(Y)-1,$LENGTH(Y))
SET J=X_Y
SET E=E_J
+11 SET B=$EXTRACT(B_$JUSTIFY("",125),1,125)
SET C=$EXTRACT(C_$JUSTIFY("",100),1,100)
SET E=$EXTRACT(E_$JUSTIFY("",175),1,175)
+12 QUIT B_U_E_U_C
+13 ;
REV(F,D) ;EP - ITSC/SET/JVK ACHS*3.1*11 ADDED FOR EXPORT OF REV
+1 ; F=DUZ(2), D=Document EIN. Return REV codes, fee, and units.
+2 ;
+3 ; B = REV Codes (25)
+4 ; E = Total Unit Fee Charged (25)($$$$$cc)
+5 ; C = REV Units (25)
+6 ;
+7 NEW A,B,C,E
+8 SET (B,C,E)=""
+9 FOR %=0:0
SET %=$ORDER(^ACHSF(F,"D",D,11,%))
IF '%
QUIT
SET A=^(%,0)
IF $PIECE($PIECE(A,U),";",2)="AUTTREVN("
SET X=$PIECE($GET(^AUTTREVN(+A,0)),U)
SET B=B_$SELECT($LENGTH(X)=3:X,1:" ")
SET X="000"_$PIECE(A,U,4)
SET X=$EXTRACT(X,$LENGTH(X)-3,$LENGTH(X))
SET C=C_$SELECT(+X:X,1:" ")
SET J=$PIECE(A,U,6)
+10 SET X="00000"_$PIECE(J,".")
SET X=$EXTRACT(X,$LENGTH(X)-4,$LENGTH(X))
SET Y="00"_$PIECE(J,".",2)
SET Y=$EXTRACT(Y,$LENGTH(Y)-1,$LENGTH(Y))
SET J=X_Y
SET E=E_J
+11 SET B=$EXTRACT(B_$JUSTIFY("",75),1,75)
SET C=$EXTRACT(C_$JUSTIFY("",100),1,100)
SET E=$EXTRACT(E_$JUSTIFY("",175),1,175)
+12 QUIT B_U_E_U_C
+13 ;
