ACHSEOB4 ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (5/6) - UPDATE DOCUMENT(2/2) ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,22,23**;JUN 11, 2001;Build 43
;
;
ICD ;EP.
;ACHS*3.1*22 ADDED FOR ICD LENGTH OF 3, TO FX ISSUE OF CSV LOOK UP BY IEN
;F ACHS=12:1:16 S ACHSX=$P(ACHSEOBR("E",ACHS)," ") I ACHSX]"" D:$L(ACHSX)<3 ICNV1 D:$L(ACHSX)>3 ICNV D I1
;F ACHS=12:1:16 S ACHSX=$P(ACHSEOBR("E",ACHS)," ") I ACHSX]"" D:$L(ACHSX)<3 ICNV1 D:$L(ACHSX)>3 ICNV S:$L(ACHSX)=3 ACHSX=ACHSX_"." D I1 ;ACHS*3.1*22
;ACHS*3.1*23 CHANGED END OF FOR LOOP TO TST FOR DATA "E" TO ACHSREJ AND FI SENDS . IN NEW FORMAT
I $$PARM^ACHS(0,17)?1N.N,DT>($$PARM^ACHS(0,17)-1) F ACHS=12:1 Q:'$D(ACHSEOBR(ACHSREJ,ACHS)) D
.S ACHSX=$P(ACHSEOBR(ACHSREJ,ACHS)," ") I ACHSX]"" D I1
I ($$PARM^ACHS(0,17)'?1N.N)!(DT<$$PARM^ACHS(0,17)) F ACHS=12:1 Q:'$D(ACHSEOBR(ACHSREJ,ACHS)) D
.S ACHSX=$P(ACHSEOBR(ACHSREJ,ACHS)," ")
.I ACHSX]"" D:$L(ACHSX)<3 ICNV1 D:$L(ACHSX)>3 ICNV S:$L(ACHSX)=3 ACHSX=ACHSX_"." D I1
Q
;
I1 ; Check DX codes first
;ACHS*3.1*18 IHS.OIT.FCJ MODIFIED FOR CSV
;S DIC(0)="M",X=$G(^DD(80,0,"DIC"))
;I X]"" X ^%ZOSF("TEST") E S DIC(0)="IM"
;S DIC="^ICD9(",D="AB",X=ACHSX
;D IX^DIC
;I Y<1 D ICDLK Q:$G(ACHSERRE)
;ACHS*3.1*23 IHS.OIT.MOD FOR ICD-10
;S Y=$P($$ICDDX^ICDCODE(ACHSX),U,1,2)
S Y=$P($$ICDDX^ICDEX(ACHSX,,,"E"),U,1,2)
I Y<0 D ERR Q
;ACHS*3.1*18 END OF CHANGES
I '$D(^ACHSF(DUZ(2),"D",ACHSDIEN,9)) S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,9,0),U,2)=$P($G(^DD(9002080.01,95,0)),U,2)
N ACHSTMP S ACHSTMP=0
;IF DUP DX OR PROC CODES SET WARNING
F S ACHSTMP=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP)) Q:ACHSTMP="" D
.Q:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP,0))
.;ACHS*3.1*23 CHG NXT LN ACHSEDAT=Y TO ACHSEDAT=$P(Y,U,2)
.I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP,0)),U)=+Y S ACHSERRE=23,ACHSEDAT=$P(Y,U,2) D ^ACHSEOBG Q
S X=+Y
S DIC(0)="M",DIC="^ACHSF(DUZ(2),""D"",ACHSDIEN,9,"
S DIC("DR")="1////^S X=ACHSTDA"
S DA(2)=DUZ(2)
S DA(1)=ACHSDIEN
K DO,DD D FILE^DICN
I Y<1 S ACHSERRE=16,ACHSEDAT=X D ^ACHSEOBG
Q
;
ICNV ; Convert E and vee codes and place decimal.
I $E(ACHSX,1)'="E" S ACHSX=$E(ACHSX,1,3)_"."_$E(ACHSX,4,5) Q
S ACHSX=$E(ACHSX,1,4)_"."_$E(ACHSX,5)
I $E(ACHSX,6)="" S ACHSX=$E(ACHSX,1,5) Q
Q
;
ICNV1 ;
S X="000",X=$E(X,1,3-$L(ACHSX)),ACHSX=X_ACHSX
Q
;
PROC ;EP
;ACHS*3.1*23 ADDED 2 MORE PROC CHANGE 10 TO 12 IN NXT LINE
F ACHS=8:1:12 I $D(ACHSEOBR("G",ACHS)) S ACHSX=$P(ACHSEOBR("G",ACHS)," ") Q:ACHSX="" D PROC1
Q
;
PROC1 ;
;ACHS*3.1*18 IHS.OIT.FCJ MODIFIED FOR CSV
;S DIC(0)="M"
;S X=$G(^DD(80.1,0,"DIC"))
;I X]"" X ^%ZOSF("TEST") E S DIC(0)="IM"
;ACHS*3.1*23 ICD-10 PROCEDURE CODE ARE 7 DIGITS
G:$L(ACHSX)=7 PROC2
S ACHSX=$P(ACHSX,".")_$P(ACHSX,".",2)
S ACHSX=$E(ACHSX,1,2)_"."_$E(ACHSX,3,$L(ACHSX))
;S DIC="^ICD0(",D="AB",X=ACHSX
;D IX^DIC
PROC2 ;
;S Y=$P($$ICDOP^ICDCODE(ACHSX),U,1,2) ;ACHS*3.1*23
S Y=$P($$ICDOP^ICDEX(ACHSX),U,1,2) ;ACHS*3.1*23
;ACHS*3.1*18 END OF CHANGES
I Y<1 S ACHSERRE=17,ACHSEDAT=ACHSX D ^ACHSEOBG Q
I '$D(^ACHSF(DUZ(2),"D",ACHSDIEN,10)) S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,10,0),U,2)=$P(^DD(9002080.01,96,0),U,2)
; Add procedure date to next line for duplicate verification,
; after FI begins sending that data.
;ACHS*3.1*23 CHG NXT LN ACHSEDAT=Y TO ACHSEDAT=$P(Y,U,2)
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,10,+Y)) S ACHSERRE=43,ACHSEDAT=$P(Y,U,2) D ^ACHSEOBG
S X=+Y
S DIC(0)="M",DIC="^ACHSF(DUZ(2),""D"",ACHSDIEN,10,"
S DIC("DR")="2////^S X=ACHSTDA"
S DA(2)=DUZ(2)
S DA(1)=ACHSDIEN
K DO,DD D FILE^DICN
I Y<1 S ACHSERRE=17,ACHSEDAT=X D ^ACHSEOBG
Q
;
CPTREV ;EP - Process EOBR CPT / REVENUE / ADA codes.
SHUNT D CPTREV^ACHSEOBZ Q ; MRS:1/3/2000
S ACHS=0
C1 ;
S ACHS=$O(^TMP("ACHSEOB",$J,"F",ACHS))
Q:'ACHS
S ACHSMRCA="" ; NO WARNING MESSAGE FOR REV/CPT/ADA YET
;S ACHSEOBR("F")=^TMP("ACHSEOB",$J,"F",ACHS),ACHSX=$E(ACHSEOBR("F"),35,39),ACHSX=$$STRIP^XLFSTR(ACHSX," ")
S ACHSEOBR("F")=^TMP("ACHSEOB",$J,"F",ACHS),ACHSX=$E(ACHSEOBR("F"),39,43),ACHSX=$$STRIP^XLFSTR(ACHSX," ")
;
S X=$S($L(ACHSX)=5:81,$L(ACHSX)=4:9999999.31,$L(ACHSX)=3:9999999.72,1:""),DIC(0)="M"
I X]"" S X=$G(^DD(X,0,"DIC"))
I X]"" X ^%ZOSF("TEST") E S DIC(0)="IM"
S DIC=$S($L(ACHSX)=5:"^ICPT(",$L(ACHSX)=4:"^AUTTADA(",1:"^AUTTREVN("),X=ACHSX
D ^DIC
I +Y>0 G DOCUMENT
G REV:$L(ACHSX)=3,ADA:$L(ACHSX)=4,CPT
;
REV ; Add missing Revenue Code.
S ACHSERRE=19,ACHSEDAT=ACHSX D ^ACHSEOBG
S X="PT CONVENCE/OTH" D ^DIC
S ACHSMRCA="WARNING: REV["_ACHSEDAT_"] FAILED, USING["_X_"]"
G DOCUMENT
;
ADA ; Add missing ADA code.
S ACHSERRE=33,ACHSEDAT=ACHSX D ^ACHSEOBG
S X="UNSPECIFIED TREATMENT" D ^DIC
S ACHSMRCA="WARNING: ADA["_ACHSEDAT_"] FAILED, USING["_X_"]"
G DOCUMENT
;
CPT ; Add missing CPT code.
S ACHSERRE=18,ACHSEDAT=ACHSX D ^ACHSEOBG
S X="UNCODED",DIC(0)="MI" D ^DIC S DIC(0)="M"
S ACHSMRCA="WARNING: CPT["_ACHSEDAT_"] FAILED, USING["_X_"]"
G DOCUMENT
;
DOCUMENT ; Add EOBR info to CPT/REV/ADA multiple in DOCUMENT multiple.
;
I '$D(^ACHSF(DUZ(2),"D",ACHSDIEN,11)) S ^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)=$$ZEROTH^ACHS(9002080.01,97)
S X=+Y_";"_$P($P(DIC,"("),U,2)_"(",DIC="^ACHSF(DUZ(2),""D"",ACHSDIEN,11,",DA(2)=DUZ(2),DA(1)=ACHSDIEN
K DO,DD D FILE^DICN
I Y<1 S ACHSERRE=$S(+ACHSX>999:18,1:19),ACHSEDAT=ACHSX D ^ACHSEOBG G C1
S Y=+Y,$P(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,2)=ACHSEOBR("F",8)-17000000,$P(^(0),U,3)=ACHSEOBR("F",9)-17000000
S $P(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,4)=ACHSEOBR("F",11)
S $P(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,5)=+$E(ACHSEOBR("F",12),1,7)_"."_$E(ACHSEOBR("F",12),8,9),$P(^(0),U,6)=+$E(ACHSEOBR("F",13),1,7)_"."_$E(ACHSEOBR("F",13),8,9)
S (ACHSMSG,X)=$P(ACHSEOBR("F",14)," ")
I X]"" S $P(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,7)=X
S X=$P(ACHSEOBR("F",15)," ")
I X]"" S $P(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,8)=X
S X=$P(ACHSEOBR("F",16)," ")
I X]"" S $P(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,9)=X
S $P(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,10)=ACHSTDA
G C1:ACHSMSG=""&(ACHSMRCA="")
G ;
S ACHSDA=0
F ACHSX=1:2 Q:'$D(^TMP("ACHSEOB",$J,"G",ACHSX)) D
. I ACHSMSG=$E(^TMP("ACHSEOB",$J,"G",ACHSX),1,4) S ACHSDA=ACHSDA+1,^ACHSF(DA(2),"D",DA(1),11,Y,1,ACHSDA,0)=ACHSMSG_" -"_$E(^TMP("ACHSEOB",$J,"G",ACHSX),5,99)_$E(^TMP("ACHSEOB",$J,"G",ACHSX+1),5,99)
.Q
I ACHSMRCA]"" D
. S ACHSDA=ACHSDA+1
. S ^ACHSF(DA(2),"D",DA(1),11,Y,1,ACHSDA,0)=ACHSMRCA
S ^ACHSF(DA(2),"D",DA(1),11,Y,1,0)=U_U_ACHSDA_U_ACHSDA_U_DT
G C1
;
ICDLK ; ACHS*3.1*23;NO LONGER USED
I $L(X)=3 S X=X_"."
I $L($P(X,".",2))>2 S ACHSX=$E(X,1,6) G ERR
S DIC="^ICD9(",DIC(0)="X",D="AB",X=X_"0"
D IX^DIC
Q:Y>0
G ICDLK
;
ERR ;
S ACHSERRE=16,ACHSEDAT=ACHSX
D ^ACHSEOBG
Q
;
SENDMSG(DIC,DA) ;
K ^TMP("ACHSEOB4",$J)
N ACHSCTR,ACHSFLD,X,XMSUB,XMDUZ,XMTEXT,XMY
S (ACHSCTR,ACHSFLD)=0
F ACHSCTR=1:1 S X=$P($T(TXT+ACHSCTR),";;",2) Q:X="###" S ^TMP("ACHSEOB4",$J,ACHSCTR)=X
S %=^DIC(DIC,0,"GL")_"0)",^TMP("ACHSEOB4",$J,ACHSCTR)="New entry # "_DA_" in the "_$P(@%,U)_" file is the following:"
S ACHSCTR=ACHSCTR+1,^TMP("ACHSEOB4",$J,ACHSCTR)=" "
F S ACHSFLD=$O(^DD(DIC,ACHSFLD)) Q:'ACHSFLD S ACHSCTR=ACHSCTR+1 S X=$J($P(^(ACHSFLD,0),U),20)_" = "_$$VAL^XBDIQ1(DIC,DA,ACHSFLD),^TMP("ACHSEOB4",$J,ACHSCTR)=X
S XMB="ACHS EOBR PROCESSING"
S XMDUZ="CHS EOBR Automatic Processing",XMSUB="Add of CPT/ADA/REV code."
S XMTEXT="^TMP(""ACHSEOB4"",$J,"
S XMY(1)=""
D ^XMB,KILL^XM
K ^TMP("ACHSEOB4",$J)
Q
;
TXT ;
;;The following information has been added to the indicated file,
;;based on information received thru automatic EOBR processing of
;;a CHS EOBR file. Please follow up on the entry to ensure more
;;complete and accurate data has been entered. Thank you.
;;
;;###
;
ACHSEOB4 ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (5/6) - UPDATE DOCUMENT(2/2) ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,22,23**;JUN 11, 2001;Build 43
+2 ;
+3 ;
ICD ;EP.
+1 ;ACHS*3.1*22 ADDED FOR ICD LENGTH OF 3, TO FX ISSUE OF CSV LOOK UP BY IEN
+2 ;F ACHS=12:1:16 S ACHSX=$P(ACHSEOBR("E",ACHS)," ") I ACHSX]"" D:$L(ACHSX)<3 ICNV1 D:$L(ACHSX)>3 ICNV D I1
+3 ;F ACHS=12:1:16 S ACHSX=$P(ACHSEOBR("E",ACHS)," ") I ACHSX]"" D:$L(ACHSX)<3 ICNV1 D:$L(ACHSX)>3 ICNV S:$L(ACHSX)=3 ACHSX=ACHSX_"." D I1 ;ACHS*3.1*22
+4 ;ACHS*3.1*23 CHANGED END OF FOR LOOP TO TST FOR DATA "E" TO ACHSREJ AND FI SENDS . IN NEW FORMAT
+5 IF $$PARM^ACHS(0,17)?1N.N
IF DT>($$PARM^ACHS(0,17)-1)
FOR ACHS=12:1
IF '$DATA(ACHSEOBR(ACHSREJ,ACHS))
QUIT
Begin DoDot:1
+6 SET ACHSX=$PIECE(ACHSEOBR(ACHSREJ,ACHS)," ")
IF ACHSX]""
DO I1
End DoDot:1
+7 IF ($$PARM^ACHS(0,17)'?1N.N)!(DT<$$PARM^ACHS(0,17))
FOR ACHS=12:1
IF '$DATA(ACHSEOBR(ACHSREJ,ACHS))
QUIT
Begin DoDot:1
+8 SET ACHSX=$PIECE(ACHSEOBR(ACHSREJ,ACHS)," ")
+9 IF ACHSX]""
IF $LENGTH(ACHSX)<3
DO ICNV1
IF $LENGTH(ACHSX)>3
DO ICNV
IF $LENGTH(ACHSX)=3
SET ACHSX=ACHSX_"."
DO I1
End DoDot:1
+10 QUIT
+11 ;
I1 ; Check DX codes first
+1 ;ACHS*3.1*18 IHS.OIT.FCJ MODIFIED FOR CSV
+2 ;S DIC(0)="M",X=$G(^DD(80,0,"DIC"))
+3 ;I X]"" X ^%ZOSF("TEST") E S DIC(0)="IM"
+4 ;S DIC="^ICD9(",D="AB",X=ACHSX
+5 ;D IX^DIC
+6 ;I Y<1 D ICDLK Q:$G(ACHSERRE)
+7 ;ACHS*3.1*23 IHS.OIT.MOD FOR ICD-10
+8 ;S Y=$P($$ICDDX^ICDCODE(ACHSX),U,1,2)
+9 SET Y=$PIECE($$ICDDX^ICDEX(ACHSX,,,"E"),U,1,2)
+10 IF Y<0
DO ERR
QUIT
+11 ;ACHS*3.1*18 END OF CHANGES
+12 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,9))
SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,9,0),U,2)=$PIECE($GET(^DD(9002080.01,95,0)),U,2)
+13 NEW ACHSTMP
SET ACHSTMP=0
+14 ;IF DUP DX OR PROC CODES SET WARNING
+15 FOR
SET ACHSTMP=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP))
IF ACHSTMP=""
QUIT
Begin DoDot:1
+16 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP,0))
QUIT
+17 ;ACHS*3.1*23 CHG NXT LN ACHSEDAT=Y TO ACHSEDAT=$P(Y,U,2)
+18 IF $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP,0)),U)=+Y
SET ACHSERRE=23
SET ACHSEDAT=$PIECE(Y,U,2)
DO ^ACHSEOBG
QUIT
End DoDot:1
+19 SET X=+Y
+20 SET DIC(0)="M"
SET DIC="^ACHSF(DUZ(2),""D"",ACHSDIEN,9,"
+21 SET DIC("DR")="1////^S X=ACHSTDA"
+22 SET DA(2)=DUZ(2)
+23 SET DA(1)=ACHSDIEN
+24 KILL DO,DD
DO FILE^DICN
+25 IF Y<1
SET ACHSERRE=16
SET ACHSEDAT=X
DO ^ACHSEOBG
+26 QUIT
+27 ;
ICNV ; Convert E and vee codes and place decimal.
+1 IF $EXTRACT(ACHSX,1)'="E"
SET ACHSX=$EXTRACT(ACHSX,1,3)_"."_$EXTRACT(ACHSX,4,5)
QUIT
+2 SET ACHSX=$EXTRACT(ACHSX,1,4)_"."_$EXTRACT(ACHSX,5)
+3 IF $EXTRACT(ACHSX,6)=""
SET ACHSX=$EXTRACT(ACHSX,1,5)
QUIT
+4 QUIT
+5 ;
ICNV1 ;
+1 SET X="000"
SET X=$EXTRACT(X,1,3-$LENGTH(ACHSX))
SET ACHSX=X_ACHSX
+2 QUIT
+3 ;
PROC ;EP
+1 ;ACHS*3.1*23 ADDED 2 MORE PROC CHANGE 10 TO 12 IN NXT LINE
+2 FOR ACHS=8:1:12
IF $DATA(ACHSEOBR("G",ACHS))
SET ACHSX=$PIECE(ACHSEOBR("G",ACHS)," ")
IF ACHSX=""
QUIT
DO PROC1
+3 QUIT
+4 ;
PROC1 ;
+1 ;ACHS*3.1*18 IHS.OIT.FCJ MODIFIED FOR CSV
+2 ;S DIC(0)="M"
+3 ;S X=$G(^DD(80.1,0,"DIC"))
+4 ;I X]"" X ^%ZOSF("TEST") E S DIC(0)="IM"
+5 ;ACHS*3.1*23 ICD-10 PROCEDURE CODE ARE 7 DIGITS
+6 IF $LENGTH(ACHSX)=7
GOTO PROC2
+7 SET ACHSX=$PIECE(ACHSX,".")_$PIECE(ACHSX,".",2)
+8 SET ACHSX=$EXTRACT(ACHSX,1,2)_"."_$EXTRACT(ACHSX,3,$LENGTH(ACHSX))
+9 ;S DIC="^ICD0(",D="AB",X=ACHSX
+10 ;D IX^DIC
PROC2 ;
+1 ;S Y=$P($$ICDOP^ICDCODE(ACHSX),U,1,2) ;ACHS*3.1*23
+2 ;ACHS*3.1*23
SET Y=$PIECE($$ICDOP^ICDEX(ACHSX),U,1,2)
+3 ;ACHS*3.1*18 END OF CHANGES
+4 IF Y<1
SET ACHSERRE=17
SET ACHSEDAT=ACHSX
DO ^ACHSEOBG
QUIT
+5 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,10))
SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,10,0),U,2)=$PIECE(^DD(9002080.01,96,0),U,2)
+6 ; Add procedure date to next line for duplicate verification,
+7 ; after FI begins sending that data.
+8 ;ACHS*3.1*23 CHG NXT LN ACHSEDAT=Y TO ACHSEDAT=$P(Y,U,2)
+9 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,10,+Y))
SET ACHSERRE=43
SET ACHSEDAT=$PIECE(Y,U,2)
DO ^ACHSEOBG
+10 SET X=+Y
+11 SET DIC(0)="M"
SET DIC="^ACHSF(DUZ(2),""D"",ACHSDIEN,10,"
+12 SET DIC("DR")="2////^S X=ACHSTDA"
+13 SET DA(2)=DUZ(2)
+14 SET DA(1)=ACHSDIEN
+15 KILL DO,DD
DO FILE^DICN
+16 IF Y<1
SET ACHSERRE=17
SET ACHSEDAT=X
DO ^ACHSEOBG
+17 QUIT
+18 ;
CPTREV ;EP - Process EOBR CPT / REVENUE / ADA codes.
SHUNT ; MRS:1/3/2000
DO CPTREV^ACHSEOBZ
QUIT
+1 SET ACHS=0
C1 ;
+1 SET ACHS=$ORDER(^TMP("ACHSEOB",$JOB,"F",ACHS))
+2 IF 'ACHS
QUIT
+3 ; NO WARNING MESSAGE FOR REV/CPT/ADA YET
SET ACHSMRCA=""
+4 ;S ACHSEOBR("F")=^TMP("ACHSEOB",$J,"F",ACHS),ACHSX=$E(ACHSEOBR("F"),35,39),ACHSX=$$STRIP^XLFSTR(ACHSX," ")
+5 SET ACHSEOBR("F")=^TMP("ACHSEOB",$JOB,"F",ACHS)
SET ACHSX=$EXTRACT(ACHSEOBR("F"),39,43)
SET ACHSX=$$STRIP^XLFSTR(ACHSX," ")
+6 ;
+7 SET X=$SELECT($LENGTH(ACHSX)=5:81,$LENGTH(ACHSX)=4:9999999.31,$LENGTH(ACHSX)=3:9999999.72,1:"")
SET DIC(0)="M"
+8 IF X]""
SET X=$GET(^DD(X,0,"DIC"))
+9 IF X]""
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET DIC(0)="IM"
+10 SET DIC=$SELECT($LENGTH(ACHSX)=5:"^ICPT(",$LENGTH(ACHSX)=4:"^AUTTADA(",1:"^AUTTREVN(")
SET X=ACHSX
+11 DO ^DIC
+12 IF +Y>0
GOTO DOCUMENT
+13 IF $LENGTH(ACHSX)=3
GOTO REV
IF $LENGTH(ACHSX)=4
GOTO ADA
GOTO CPT
+14 ;
REV ; Add missing Revenue Code.
+1 SET ACHSERRE=19
SET ACHSEDAT=ACHSX
DO ^ACHSEOBG
+2 SET X="PT CONVENCE/OTH"
DO ^DIC
+3 SET ACHSMRCA="WARNING: REV["_ACHSEDAT_"] FAILED, USING["_X_"]"
+4 GOTO DOCUMENT
+5 ;
ADA ; Add missing ADA code.
+1 SET ACHSERRE=33
SET ACHSEDAT=ACHSX
DO ^ACHSEOBG
+2 SET X="UNSPECIFIED TREATMENT"
DO ^DIC
+3 SET ACHSMRCA="WARNING: ADA["_ACHSEDAT_"] FAILED, USING["_X_"]"
+4 GOTO DOCUMENT
+5 ;
CPT ; Add missing CPT code.
+1 SET ACHSERRE=18
SET ACHSEDAT=ACHSX
DO ^ACHSEOBG
+2 SET X="UNCODED"
SET DIC(0)="MI"
DO ^DIC
SET DIC(0)="M"
+3 SET ACHSMRCA="WARNING: CPT["_ACHSEDAT_"] FAILED, USING["_X_"]"
+4 GOTO DOCUMENT
+5 ;
DOCUMENT ; Add EOBR info to CPT/REV/ADA multiple in DOCUMENT multiple.
+1 ;
+2 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,11))
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)=$$ZEROTH^ACHS(9002080.01,97)
+3 SET X=+Y_";"_$PIECE($PIECE(DIC,"("),U,2)_"("
SET DIC="^ACHSF(DUZ(2),""D"",ACHSDIEN,11,"
SET DA(2)=DUZ(2)
SET DA(1)=ACHSDIEN
+4 KILL DO,DD
DO FILE^DICN
+5 IF Y<1
SET ACHSERRE=$SELECT(+ACHSX>999:18,1:19)
SET ACHSEDAT=ACHSX
DO ^ACHSEOBG
GOTO C1
+6 SET Y=+Y
SET $PIECE(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,2)=ACHSEOBR("F",8)-17000000
SET $PIECE(^(0),U,3)=ACHSEOBR("F",9)-17000000
+7 SET $PIECE(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,4)=ACHSEOBR("F",11)
+8 SET $PIECE(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,5)=+$EXTRACT(ACHSEOBR("F",12),1,7)_"."_$EXTRACT(ACHSEOBR("F",12),8,9)
SET $PIECE(^(0),U,6)=+$EXTRACT(ACHSEOBR("F",13),1,7)_"."_$EXTRACT(ACHSEOBR("F",13),8,9)
+9 SET (ACHSMSG,X)=$PIECE(ACHSEOBR("F",14)," ")
+10 IF X]""
SET $PIECE(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,7)=X
+11 SET X=$PIECE(ACHSEOBR("F",15)," ")
+12 IF X]""
SET $PIECE(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,8)=X
+13 SET X=$PIECE(ACHSEOBR("F",16)," ")
+14 IF X]""
SET $PIECE(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,9)=X
+15 SET $PIECE(^ACHSF(DA(2),"D",DA(1),11,Y,0),U,10)=ACHSTDA
+16 IF ACHSMSG=""&(ACHSMRCA="")
GOTO C1
G ;
+1 SET ACHSDA=0
+2 FOR ACHSX=1:2
IF '$DATA(^TMP("ACHSEOB",$JOB,"G",ACHSX))
QUIT
Begin DoDot:1
+3 IF ACHSMSG=$EXTRACT(^TMP("ACHSEOB",$JOB,"G",ACHSX),1,4)
SET ACHSDA=ACHSDA+1
SET ^ACHSF(DA(2),"D",DA(1),11,Y,1,ACHSDA,0)=ACHSMSG_" -"_$EXTRACT(^TMP("ACHSEOB",$JOB,"G",ACHSX),5,99)_$EXTRACT(^TMP("ACHSEOB",$JOB,"G",ACHSX+1),5,99)
+4 QUIT
End DoDot:1
+5 IF ACHSMRCA]""
Begin DoDot:1
+6 SET ACHSDA=ACHSDA+1
+7 SET ^ACHSF(DA(2),"D",DA(1),11,Y,1,ACHSDA,0)=ACHSMRCA
End DoDot:1
+8 SET ^ACHSF(DA(2),"D",DA(1),11,Y,1,0)=U_U_ACHSDA_U_ACHSDA_U_DT
+9 GOTO C1
+10 ;
ICDLK ; ACHS*3.1*23;NO LONGER USED
+1 IF $LENGTH(X)=3
SET X=X_"."
+2 IF $LENGTH($PIECE(X,".",2))>2
SET ACHSX=$EXTRACT(X,1,6)
GOTO ERR
+3 SET DIC="^ICD9("
SET DIC(0)="X"
SET D="AB"
SET X=X_"0"
+4 DO IX^DIC
+5 IF Y>0
QUIT
+6 GOTO ICDLK
+7 ;
ERR ;
+1 SET ACHSERRE=16
SET ACHSEDAT=ACHSX
+2 DO ^ACHSEOBG
+3 QUIT
+4 ;
SENDMSG(DIC,DA) ;
+1 KILL ^TMP("ACHSEOB4",$JOB)
+2 NEW ACHSCTR,ACHSFLD,X,XMSUB,XMDUZ,XMTEXT,XMY
+3 SET (ACHSCTR,ACHSFLD)=0
+4 FOR ACHSCTR=1:1
SET X=$PIECE($TEXT(TXT+ACHSCTR),";;",2)
IF X="###"
QUIT
SET ^TMP("ACHSEOB4",$JOB,ACHSCTR)=X
+5 SET %=^DIC(DIC,0,"GL")_"0)"
SET ^TMP("ACHSEOB4",$JOB,ACHSCTR)="New entry # "_DA_" in the "_$PIECE(@%,U)_" file is the following:"
+6 SET ACHSCTR=ACHSCTR+1
SET ^TMP("ACHSEOB4",$JOB,ACHSCTR)=" "
+7 FOR
SET ACHSFLD=$ORDER(^DD(DIC,ACHSFLD))
IF 'ACHSFLD
QUIT
SET ACHSCTR=ACHSCTR+1
SET X=$JUSTIFY($PIECE(^(ACHSFLD,0),U),20)_" = "_$$VAL^XBDIQ1(DIC,DA,ACHSFLD)
SET ^TMP("ACHSEOB4",$JOB,ACHSCTR)=X
+8 SET XMB="ACHS EOBR PROCESSING"
+9 SET XMDUZ="CHS EOBR Automatic Processing"
SET XMSUB="Add of CPT/ADA/REV code."
+10 SET XMTEXT="^TMP(""ACHSEOB4"",$J,"
+11 SET XMY(1)=""
+12 DO ^XMB
DO KILL^XM
+13 KILL ^TMP("ACHSEOB4",$JOB)
+14 QUIT
+15 ;
TXT ;
+1 ;;The following information has been added to the indicated file,
+2 ;;based on information received thru automatic EOBR processing of
+3 ;;a CHS EOBR file. Please follow up on the entry to ensure more
+4 ;;complete and accurate data has been entered. Thank you.
+5 ;;
+6 ;;###
+7 ;
