ACHSEOB4.m

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       ;