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