APCDCPOV.m

APCDCPOV ; IHS/CMI/LAB - POV LOOKUP ;

 ;;2.0;IHS PCC SUITE;**11,13,16,20**;MAY 14, 2009;Build 25

 ;

START ;

 D EN^XBNEW("LEX^APCDCPOV","APCDDATE;APCDTCLK;APCDVSIT;APCDTDIA,APCDT90;APCDTIN9")

 Q

LEX ;EP - called from input template

 I APCDTDIA=".09" S APCDTDIA=$S(APCDT90=1!($G(APCDTIN9)):"  CAUSE (E-Code)",1:"  CAUSE (V00-Y99 Code Range)")

 I APCDTDIA=".18" S APCDTDIA=$S(APCDT90=1!($G(APCDTIN9)):"  CAUSE (E-Code) #2",1:"  CAUSE (V00-Y99 Code Range) #2")

 I APCDTDIA=".19" S APCDTDIA=$S(APCDT90=1!($G(APCDTIN9)):"  CAUSE (E-Code) #3",1:"  CAUSE (V00-Y99 Code Range) #3")

 S APCDTPCC="",APCDINPE=1

 ;FOR NOW IF ICD9 CALL LEX, AFTER VA SENDS OUT ICD10 LEX JUST D LEX Q

 I $G(APCDTIN9) S APCDD=$$FMADD^XLFDT($$IMP^ICDEX(30),-2),APCDIMP=1 G LEX1

 S APCDD=""

 I $G(APCDINAD) S APCDD=$S($D(APCDDATE):APCDDATE,1:DT) G I

 I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D

 .I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S APCDD=$$DSCHDATE^APCLV(APCDVSIT) Q

 .S APCDD=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")

 I APCDD="" S APCDD=$P($G(APCDDATE),".")

 I APCDD="" S APCDD=DT

 NEW APCDIMP,APCDANS

I ;

 S APCDIMP=$$IMP^AUPNSICD(APCDD)

 ;EP - called from input template

LEX1 ;reader call to get TEXT for code

 K DIR

 K ^TMP("LEXSCH",$J)

 I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDD,"."))

 I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))

 S DIR(0)="FO^1:60",DIR("A")=$S($G(APCDTDIA)]"":APCDTDIA,1:"Enter PURPOSE OF VISIT")

 S DIR("?")=$S($G(APCDTIN9):"^D HELPE9^AUPNSIC9",1:"^D HELPE^AUPNSICH")

 S DIR("??")=$S($G(APCDTIN9):"^D HELPE9^AUPNSIC9",1:"^D HELPE^AUPNSICH")

 KILL DA D ^DIR KILL DIR

 I $D(DIRUT) S APCDTSKI=1,APCDLOOK="" G XITL

 I Y="" S APCDTSKI=1,APCDLOOK="" G XITL

 S APCDUINP=Y

 K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),LEX,^TMP("LEXFND",$J)

 I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDD,"."))

 I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))

 S X=APCDUINP

 I APCDIMP=1 S DIC("S")=$S('$G(APCDTIN9):"I $$ICDONE9^APCDCPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDCPOV(+Y,LEXVDT)")

 I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDCPOV(+Y,LEXVDT)"

 S DIC("A")=$S($G(APCDTDIA)]"":APCDTDIA_": ",1:"Enter PURPOSE OF VISIT: ")

 I APCDIMP=1 D LOOK^LEXA(X,"ICD",999,"ICD",$P(APCDD,"."))

 I APCDIMP=30 D LOOK^LEXA(X,"10D",999,"10D",$P(APCDD,"."))

 I 'LEX D  G:%="" LEX G:% LEXN

 .S X=0 F  S X=$O(LEX("HLP",X)) Q:X'=+X  W !,LEX("HLP",X)

 .;now check fileman V2.0 PATCH 20 CR#554

 .W !!,"now trying secondary fileman lookup..."

 .S %="" S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ",DIC("S")="D CHKE^AUPNSICD" D ^DIC K DIC

 .S %="" I $P(Y,U)'=-1 S %=+Y

 ;display all codes and call reader

 S APCDANS=""

 D GETANS^APCDAPOV

 I APCDY="^" W ! D  G:%="" LEX G:% LEXN

 .;now check fileman

 .;W !!,"now trying fileman lookup..."

 .S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="QME" D ^DIC K DIC

 .;S %="" I $P(Y,U)'=-1 S %=+Y

 I APCDY="" W ! D  G:%="" LEX G:% LEXN

 .;now check fileman

 .;W !!,"now trying fileman lookup..."

 .S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC

 .;S %="" I $P(Y,U)'=-1 S %=+Y

 I '$G(APCDY) W ! D  G:%="" LEX G:% LEXN

 .;now check fileman

 .;W !!,"now trying fileman lookup..."

 .S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC

 .;S %="" I $P(Y,U)'=-1 S %=+Y

 I APCDIMP=1 S Y=$$ICDONE^LEXU($P(^TMP("LEXHIT",$J,APCDY),U,1),$P(APCDD,"."))

 I APCDIMP=30 S Y=$$ONE^LEXU($P(^TMP("LEXHIT",$J,APCDY),U,1),$P(APCDD,"."),"10D")

 K DO,^TMP("LEXSCH",$J)

 I $G(Y)="" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDTCLK="" G XITL

 S %=$$ICDDX^ICDEX(Y,$P(APCDD,"."),APCDIMP,"E")

 I $P(%,U,1)="-1" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDTCLK="" G XITL

LEXN ;

 S APCDTCLK="`"_+%

 W !

XITL K Y,X,DO,D,DD,DIPGM,APCDTPCC

 Q

INJ(C,S) ;EP

 NEW %

 S %=""

 I S=1 D  Q %

 .I $E(C,1)="E" S %=0 Q

 .I $E(C,1)="V" S %=0 Q

 .I $P(C,".",1)<800 S %=0 Q

 .S %=1

 I $E(C,1)="S" Q 1  ;only codes V00-Y99 per Leslie Racine.

 I $E(C,1)="T",$E(C,2,3)<89 Q 1

 Q 0

ICDONE9(ALEX,ALEXVDT) ;EP - Return one ICD code for an expression

 ;    LEX      IEN of file 757.01

 ;    LEXVDT   Date to use for screening by codes

 N ALEXICD

 S ALEXVDT=$S(+$G(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)

 S ALEX=$$ICDONE^LEXU(ALEX,ALEXVDT) Q:ALEX="" ""

 S ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,1,"E")

 Q:$P(ALEXICD,"^",2)="INVALID CODE" ""

 Q:'$$CHKE1^AUPNSICD($P(ALEXICD,U,1)) ""

 Q 1

 ;

ICDONE99(ALEX,ALEXVDT) ;EP - Return one ICD code for an expression

 ;    LEX      IEN of file 757.01

 ;    LEXVDT   Date to use for screening by codes

 N ALEXICD

 S ALEXVDT=$S(+$G(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)

 S ALEX=$$ICDONE^LEXU(ALEX,ALEXVDT) Q:ALEX="" ""

 S ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,1,"E")

 Q:$P(ALEXICD,"^",2)="INVALID CODE" ""

 Q:'$$CHKE91^AUPNSIC9($P(ALEXICD,U,1)) ""

 Q 1

 ;

ICDONE1(ALEX,ALEXVDT) ;EP - Return one ICD code for an expression

 ;    LEX      IEN of file 757.01

 ;    LEXVDT   Date to use for screening by codes

 N ALEXICD

 ;S ALEXVDT=$S(+$G(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)

 S ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D") Q:ALEX="" ""

 S ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,30,"E")

 Q:$P(ALEXICD,"^",2)="INVALID CODE" ""

 Q:'$$CHKE1^AUPNSICD($P(ALEXICD,U,1)) ""

 Q 1

EDITCAU1 ;

 I APCDTFIE=".09"!(APCDTFIE=".25") S APCDTDIA=$S(APCDT90=1!($G(APCDTIN9)):"    CAUSE (E-Code)",1:"    CAUSE (V00-Y99 Code Range)")

 I APCDTFIE=".18"!(APCDTFIE=".26") S APCDTDIA=$S(APCDT90=1!($G(APCDTIN9)):"    CAUSE (E-Code) #2",1:"    CAUSE (V00-Y99 Code Range) #2")

 I APCDTFIE=".19"!(APCDTFIE=".27") S APCDTDIA=$S(APCDT90=1!($G(APCDTIN9)):"    CAUSE (E-Code) #3",1:"    CAUSE (V00-Y99 Code Range) #3")

 S APCDTPCC="",APCDINPE=1

 K DIR

 S APCDTPCC="",APCDINPE=1,APCDTNPV="",APCDTNOG=""

 I $G(APCDTIN9) S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1 G CLEX

 S APCDD=""

 I $G(APCDINAD) S APCDD=$S($D(APCDDATE):APCDDATE,1:DT) G CI

 I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D

 .I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S APCDD=$$DSCHDATE^APCLV(APCDVSIT) Q

 .S APCDD=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")

 I APCDD="" S APCDD=$P($G(APCDDATE),".")

 I APCDD="" S APCDD=DT

 NEW APCDIMP,APCDANS

CI ;

 S APCDIMP=$$IMP^AUPNSICD(APCDD)

CLEX ;EP

 ;reader call to get TEXT for code

 K DIR,APCDTDEL,APCDTUPH

 K ^TMP("LEXSCH",$J)

 I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDD,"."))

 I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))

 S DIR(0)="FO^1:60",DIR("A")=APCDTDIA

 S DIR("?")=$S($G(APCDTIN9):"^D HELPE9^AUPNSIC9",1:"^D HELPE^AUPNSICH")

 S DIR("??")=$S($G(APCDTIN9):"^D HELPE9^AUPNSIC9",1:"^D HELPE^AUPNSICH")

 I $$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)]"" S DIR("B")=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)

 KILL DA D ^DIR KILL DIR

 I X="@",$G(APCDIAIE) S APCDTDEL=1 G XITC

 I X=U S APCDTUPH=1 G XITC

 I $D(DIRUT) S APCDTSKI=1 G XITC

 I Y="" G XITC

 S APCDUINP=Y

 I APCDUINP=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE) G XITC

 S %=""

 I APCDUINP=".9999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999"),,APCDIMP,"E") G LEXC

 I APCDIMP=30,APCDUINP="ZZZ.999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXC

 I APCDIMP=30,$E(APCDUINP,1,4)="ZZZ." S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXC

 I $E(APCDUINP,1,7)="UNCODED" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXC

 I APCDUINP["UNCODED D" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXC

 K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),LEX,^TMP("LEXFND",$J)

 I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDD,"."))

 I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))

 S X=APCDUINP

 I APCDIMP=1 S DIC("S")=$S('$G(APCDTIN9):"I $$ICDONE9^APCDCPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDCPOV(+Y,LEXVDT)")

 I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDCPOV(+Y,LEXVDT)"

 I $G(APCDTDIA)]"" S DIC("A")=$G(APCDTDIA)

 I APCDIMP=1 D LOOK^LEXA(X,"ICD",999,"ICD",$P(APCDD,"."))

 I APCDIMP=30 D LOOK^LEXA(X,"10D",999,"10D",$P(APCDD,"."))

 I 'LEX D  G:%="" CLEX G:% LEXC

 .S X=0 F  S X=$O(LEX("HLP",X)) Q:X'=+X  W !,LEX("HLP",X)

 .;now check fileman V2.0 PATCH 20 CR#554

 .W !!,"now trying secondary fileman lookup..."

 .S %="" S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ",DIC("S")="D CHKE^AUPNSICD" D ^DIC K DIC

 .S %="" I $P(Y,U)'=-1 S %=+Y

 ;display all codes and call reader

 S APCDANS=""

 D GETANS^APCDAPOV

 I APCDY="^" W ! D  G:%="" CLEX G:% LEXC

 .;now check fileman

 .;W !!,"now trying fileman lookup..."

 .S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="QME" D ^DIC K DIC

 .;S %="" I $P(Y,U)'=-1 S %=+Y

 I APCDY="" W ! D  G:%="" CLEX G:% LEXC

 .;now check fileman

 .;W !!,"now trying fileman lookup..."

 .S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC

 .;S %="" I $P(Y,U)'=-1 S %=+Y

 I '$G(APCDY) W ! D  G:%="" CLEX G:% LEXC

 .;now check fileman

 .;W !!,"now trying fileman lookup..."

 .S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC

 .;S %="" I $P(Y,U)'=-1 S %=+Y

 I APCDIMP=1 S Y=$$ICDONE^LEXU($P(^TMP("LEXHIT",$J,APCDY),U,1),$P(APCDD,"."))

 I APCDIMP=30 S Y=$$ONE^LEXU($P(^TMP("LEXHIT",$J,APCDY),U,1),$P(APCDD,"."),"10D")

 K DO,^TMP("LEXSCH",$J)

 I $G(Y)="" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDTNPV="" G XITC

 S %=$$ICDDX^ICDEX(Y,$P(APCDD,"."),APCDIMP,"E")

 I $P(%,U,1)="-1" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDTNPV="" G XITC

LEXC ;

 S APCDTNPV="`"_+%

 W !

XITC K Y,X,DO,D,DD,DIPGM,APCDTPCC

 Q

APCDCPOV  ; IHS/CMI/LAB - POV LOOKUP ;

 +1       ;;2.0;IHS PCC SUITE;**11,13,16,20**;MAY 14, 2009;Build 25

 +2       ;

START     ;

 +1        DO EN^XBNEW("LEX^APCDCPOV","APCDDATE;APCDTCLK;APCDVSIT;APCDTDIA,APCDT90;APCDTIN9")

 +2        QUIT 

LEX       ;EP - called from input template

 +1        IF APCDTDIA=".09"

               SET APCDTDIA=$SELECT(APCDT90=1!($GET(APCDTIN9)):"  CAUSE (E-Code)",1:"  CAUSE (V00-Y99 Code Range)")

 +2        IF APCDTDIA=".18"

               SET APCDTDIA=$SELECT(APCDT90=1!($GET(APCDTIN9)):"  CAUSE (E-Code) #2",1:"  CAUSE (V00-Y99 Code Range) #2")

 +3        IF APCDTDIA=".19"

               SET APCDTDIA=$SELECT(APCDT90=1!($GET(APCDTIN9)):"  CAUSE (E-Code) #3",1:"  CAUSE (V00-Y99 Code Range) #3")

 +4        SET APCDTPCC=""

           SET APCDINPE=1

 +5       ;FOR NOW IF ICD9 CALL LEX, AFTER VA SENDS OUT ICD10 LEX JUST D LEX Q

 +6        IF $GET(APCDTIN9)

               SET APCDD=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)

               SET APCDIMP=1

               GOTO LEX1

 +7        SET APCDD=""

 +8        IF $GET(APCDINAD)

               SET APCDD=$SELECT($DATA(APCDDATE):APCDDATE,1:DT)

               GOTO I

 +9        IF $GET(APCDVSIT)

               IF $DATA(^AUPNVSIT(APCDVSIT))

                   Begin DoDot:1

 +10                   IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"

                           IF $$DSCHDATE^APCLV(APCDVSIT)]""

                               SET APCDD=$$DSCHDATE^APCLV(APCDVSIT)

                               QUIT 

 +11                   SET APCDD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")

                   End DoDot:1

 +12       IF APCDD=""

               SET APCDD=$PIECE($GET(APCDDATE),".")

 +13       IF APCDD=""

               SET APCDD=DT

 +14       NEW APCDIMP,APCDANS

I         ;

 +1        SET APCDIMP=$$IMP^AUPNSICD(APCDD)

 +2       ;EP - called from input template

LEX1      ;reader call to get TEXT for code

 +1        KILL DIR

 +2        KILL ^TMP("LEXSCH",$JOB)

 +3        IF APCDIMP=1

               DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDD,"."))

 +4        IF APCDIMP=30

               DO CONFIG^LEXSET("10D","10D",$PIECE(APCDD,"."))

 +5        SET DIR(0)="FO^1:60"

           SET DIR("A")=$SELECT($GET(APCDTDIA)]"":APCDTDIA,1:"Enter PURPOSE OF VISIT")

 +6        SET DIR("?")=$SELECT($GET(APCDTIN9):"^D HELPE9^AUPNSIC9",1:"^D HELPE^AUPNSICH")

 +7        SET DIR("??")=$SELECT($GET(APCDTIN9):"^D HELPE9^AUPNSIC9",1:"^D HELPE^AUPNSICH")

 +8        KILL DA

           DO ^DIR

           KILL DIR

 +9        IF $DATA(DIRUT)

               SET APCDTSKI=1

               SET APCDLOOK=""

               GOTO XITL

 +10       IF Y=""

               SET APCDTSKI=1

               SET APCDLOOK=""

               GOTO XITL

 +11       SET APCDUINP=Y

 +12       KILL ^TMP("LEXSCH",$JOB),^TMP("LEXHIT",$JOB),LEX,^TMP("LEXFND",$JOB)

 +13       IF APCDIMP=1

               DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDD,"."))

 +14       IF APCDIMP=30

               DO CONFIG^LEXSET("10D","10D",$PIECE(APCDD,"."))

 +15       SET X=APCDUINP

 +16       IF APCDIMP=1

               SET DIC("S")=$SELECT('$GET(APCDTIN9):"I $$ICDONE9^APCDCPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDCPOV(+Y,LEXVDT)")

 +17       IF APCDIMP=30

               SET DIC("S")="I $$ICDONE1^APCDCPOV(+Y,LEXVDT)"

 +18       SET DIC("A")=$SELECT($GET(APCDTDIA)]"":APCDTDIA_": ",1:"Enter PURPOSE OF VISIT: ")

 +19       IF APCDIMP=1

               DO LOOK^LEXA(X,"ICD",999,"ICD",$PIECE(APCDD,"."))

 +20       IF APCDIMP=30

               DO LOOK^LEXA(X,"10D",999,"10D",$PIECE(APCDD,"."))

 +21       IF 'LEX

               Begin DoDot:1

 +22               SET X=0

                   FOR 

                       SET X=$ORDER(LEX("HLP",X))

                       IF X'=+X

                           QUIT 

                       WRITE !,LEX("HLP",X)

 +23      ;now check fileman V2.0 PATCH 20 CR#554

 +24               WRITE !!,"now trying secondary fileman lookup..."

 +25               SET %=""

                   SET X=APCDUINP

                   SET DIC="^ICD9("

                   SET DIC(0)="MEQ"

                   SET DIC("S")="D CHKE^AUPNSICD"

                   DO ^DIC

                   KILL DIC

 +26               SET %=""

                   IF $PIECE(Y,U)'=-1

                       SET %=+Y

               End DoDot:1

               IF %=""

                   GOTO LEX

               IF %

                   GOTO LEXN

 +27      ;display all codes and call reader

 +28       SET APCDANS=""

 +29       DO GETANS^APCDAPOV

 +30       IF APCDY="^"

               WRITE !

               Begin DoDot:1

 +31      ;now check fileman

 +32      ;W !!,"now trying fileman lookup..."

 +33      ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="QME" D ^DIC K DIC

                   SET %=""

 +34      ;S %="" I $P(Y,U)'=-1 S %=+Y

               End DoDot:1

               IF %=""

                   GOTO LEX

               IF %

                   GOTO LEXN

 +35       IF APCDY=""

               WRITE !

               Begin DoDot:1

 +36      ;now check fileman

 +37      ;W !!,"now trying fileman lookup..."

 +38      ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC

                   SET %=""

 +39      ;S %="" I $P(Y,U)'=-1 S %=+Y

               End DoDot:1

               IF %=""

                   GOTO LEX

               IF %

                   GOTO LEXN

 +40       IF '$GET(APCDY)

               WRITE !

               Begin DoDot:1

 +41      ;now check fileman

 +42      ;W !!,"now trying fileman lookup..."

 +43      ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC

                   SET %=""

 +44      ;S %="" I $P(Y,U)'=-1 S %=+Y

               End DoDot:1

               IF %=""

                   GOTO LEX

               IF %

                   GOTO LEXN

 +45       IF APCDIMP=1

               SET Y=$$ICDONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."))

 +46       IF APCDIMP=30

               SET Y=$$ONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."),"10D")

 +47       KILL DO,^TMP("LEXSCH",$JOB)

 +48       IF $GET(Y)=""

               WRITE !!,"lexicon isn't passing back an ICD code."

               SET APCDTERR=1

               SET APCDTCLK=""

               GOTO XITL

 +49       SET %=$$ICDDX^ICDEX(Y,$PIECE(APCDD,"."),APCDIMP,"E")

 +50       IF $PIECE(%,U,1)="-1"

               WRITE !!,"lexicon isn't passing back an ICD code."

               SET APCDTERR=1

               SET APCDTCLK=""

               GOTO XITL

LEXN      ;

 +1        SET APCDTCLK="`"_+%

 +2        WRITE !

XITL       KILL Y,X,DO,D,DD,DIPGM,APCDTPCC

 +1        QUIT 

INJ(C,S)  ;EP

 +1        NEW %

 +2        SET %=""

 +3        IF S=1

               Begin DoDot:1

 +4                IF $EXTRACT(C,1)="E"

                       SET %=0

                       QUIT 

 +5                IF $EXTRACT(C,1)="V"

                       SET %=0

                       QUIT 

 +6                IF $PIECE(C,".",1)<800

                       SET %=0

                       QUIT 

 +7                SET %=1

               End DoDot:1

               QUIT %

 +8       ;only codes V00-Y99 per Leslie Racine.

           IF $EXTRACT(C,1)="S"

               QUIT 1

 +9        IF $EXTRACT(C,1)="T"

               IF $EXTRACT(C,2,3)<89

                   QUIT 1

 +10       QUIT 0

ICDONE9(ALEX,ALEXVDT) ;EP - Return one ICD code for an expression

 +1       ;    LEX      IEN of file 757.01

 +2       ;    LEXVDT   Date to use for screening by codes

 +3        NEW ALEXICD

 +4        SET ALEXVDT=$SELECT(+$GET(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)

 +5        SET ALEX=$$ICDONE^LEXU(ALEX,ALEXVDT)

           IF ALEX=""

               QUIT ""

 +6        SET ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,1,"E")

 +7        IF $PIECE(ALEXICD,"^",2)="INVALID CODE"

               QUIT ""

 +8        IF '$$CHKE1^AUPNSICD($PIECE(ALEXICD,U,1))

               QUIT ""

 +9        QUIT 1

 +10      ;

ICDONE99(ALEX,ALEXVDT) ;EP - Return one ICD code for an expression

 +1       ;    LEX      IEN of file 757.01

 +2       ;    LEXVDT   Date to use for screening by codes

 +3        NEW ALEXICD

 +4        SET ALEXVDT=$SELECT(+$GET(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)

 +5        SET ALEX=$$ICDONE^LEXU(ALEX,ALEXVDT)

           IF ALEX=""

               QUIT ""

 +6        SET ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,1,"E")

 +7        IF $PIECE(ALEXICD,"^",2)="INVALID CODE"

               QUIT ""

 +8        IF '$$CHKE91^AUPNSIC9($PIECE(ALEXICD,U,1))

               QUIT ""

 +9        QUIT 1

 +10      ;

ICDONE1(ALEX,ALEXVDT) ;EP - Return one ICD code for an expression

 +1       ;    LEX      IEN of file 757.01

 +2       ;    LEXVDT   Date to use for screening by codes

 +3        NEW ALEXICD

 +4       ;S ALEXVDT=$S(+$G(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)

 +5        SET ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D")

           IF ALEX=""

               QUIT ""

 +6        SET ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,30,"E")

 +7        IF $PIECE(ALEXICD,"^",2)="INVALID CODE"

               QUIT ""

 +8        IF '$$CHKE1^AUPNSICD($PIECE(ALEXICD,U,1))

               QUIT ""

 +9        QUIT 1

EDITCAU1  ;

 +1        IF APCDTFIE=".09"!(APCDTFIE=".25")

               SET APCDTDIA=$SELECT(APCDT90=1!($GET(APCDTIN9)):"    CAUSE (E-Code)",1:"    CAUSE (V00-Y99 Code Range)")

 +2        IF APCDTFIE=".18"!(APCDTFIE=".26")

               SET APCDTDIA=$SELECT(APCDT90=1!($GET(APCDTIN9)):"    CAUSE (E-Code) #2",1:"    CAUSE (V00-Y99 Code Range) #2")

 +3        IF APCDTFIE=".19"!(APCDTFIE=".27")

               SET APCDTDIA=$SELECT(APCDT90=1!($GET(APCDTIN9)):"    CAUSE (E-Code) #3",1:"    CAUSE (V00-Y99 Code Range) #3")

 +4        SET APCDTPCC=""

           SET APCDINPE=1

 +5        KILL DIR

 +6        SET APCDTPCC=""

           SET APCDINPE=1

           SET APCDTNPV=""

           SET APCDTNOG=""

 +7        IF $GET(APCDTIN9)

               SET APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2)

               SET APCDIMP=1

               GOTO CLEX

 +8        SET APCDD=""

 +9        IF $GET(APCDINAD)

               SET APCDD=$SELECT($DATA(APCDDATE):APCDDATE,1:DT)

               GOTO CI

 +10       IF $GET(APCDVSIT)

               IF $DATA(^AUPNVSIT(APCDVSIT))

                   Begin DoDot:1

 +11                   IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"

                           IF $$DSCHDATE^APCLV(APCDVSIT)]""

                               SET APCDD=$$DSCHDATE^APCLV(APCDVSIT)

                               QUIT 

 +12                   SET APCDD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")

                   End DoDot:1

 +13       IF APCDD=""

               SET APCDD=$PIECE($GET(APCDDATE),".")

 +14       IF APCDD=""

               SET APCDD=DT

 +15       NEW APCDIMP,APCDANS

CI        ;

 +1        SET APCDIMP=$$IMP^AUPNSICD(APCDD)

CLEX      ;EP

 +1       ;reader call to get TEXT for code

 +2        KILL DIR,APCDTDEL,APCDTUPH

 +3        KILL ^TMP("LEXSCH",$JOB)

 +4        IF APCDIMP=1

               DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDD,"."))

 +5        IF APCDIMP=30

               DO CONFIG^LEXSET("10D","10D",$PIECE(APCDD,"."))

 +6        SET DIR(0)="FO^1:60"

           SET DIR("A")=APCDTDIA

 +7        SET DIR("?")=$SELECT($GET(APCDTIN9):"^D HELPE9^AUPNSIC9",1:"^D HELPE^AUPNSICH")

 +8        SET DIR("??")=$SELECT($GET(APCDTIN9):"^D HELPE9^AUPNSIC9",1:"^D HELPE^AUPNSICH")

 +9        IF $$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)]""

               SET DIR("B")=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)

 +10       KILL DA

           DO ^DIR

           KILL DIR

 +11       IF X="@"

               IF $GET(APCDIAIE)

                   SET APCDTDEL=1

                   GOTO XITC

 +12       IF X=U

               SET APCDTUPH=1

               GOTO XITC

 +13       IF $DATA(DIRUT)

               SET APCDTSKI=1

               GOTO XITC

 +14       IF Y=""

               GOTO XITC

 +15       SET APCDUINP=Y

 +16       IF APCDUINP=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)

               GOTO XITC

 +17       SET %=""

 +18       IF APCDUINP=".9999"

               SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),,APCDIMP,"E")

               GOTO LEXC

 +19       IF APCDIMP=30

               IF APCDUINP="ZZZ.999"

                   SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))

                   GOTO LEXC

 +20       IF APCDIMP=30

               IF $EXTRACT(APCDUINP,1,4)="ZZZ."

                   SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))

                   GOTO LEXC

 +21       IF $EXTRACT(APCDUINP,1,7)="UNCODED"

               SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))

               GOTO LEXC

 +22       IF APCDUINP["UNCODED D"

               SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))

               GOTO LEXC

 +23       KILL ^TMP("LEXSCH",$JOB),^TMP("LEXHIT",$JOB),LEX,^TMP("LEXFND",$JOB)

 +24       IF APCDIMP=1

               DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDD,"."))

 +25       IF APCDIMP=30

               DO CONFIG^LEXSET("10D","10D",$PIECE(APCDD,"."))

 +26       SET X=APCDUINP

 +27       IF APCDIMP=1

               SET DIC("S")=$SELECT('$GET(APCDTIN9):"I $$ICDONE9^APCDCPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDCPOV(+Y,LEXVDT)")

 +28       IF APCDIMP=30

               SET DIC("S")="I $$ICDONE1^APCDCPOV(+Y,LEXVDT)"

 +29       IF $GET(APCDTDIA)]""

               SET DIC("A")=$GET(APCDTDIA)

 +30       IF APCDIMP=1

               DO LOOK^LEXA(X,"ICD",999,"ICD",$PIECE(APCDD,"."))

 +31       IF APCDIMP=30

               DO LOOK^LEXA(X,"10D",999,"10D",$PIECE(APCDD,"."))

 +32       IF 'LEX

               Begin DoDot:1

 +33               SET X=0

                   FOR 

                       SET X=$ORDER(LEX("HLP",X))

                       IF X'=+X

                           QUIT 

                       WRITE !,LEX("HLP",X)

 +34      ;now check fileman V2.0 PATCH 20 CR#554

 +35               WRITE !!,"now trying secondary fileman lookup..."

 +36               SET %=""

                   SET X=APCDUINP

                   SET DIC="^ICD9("

                   SET DIC(0)="MEQ"

                   SET DIC("S")="D CHKE^AUPNSICD"

                   DO ^DIC

                   KILL DIC

 +37               SET %=""

                   IF $PIECE(Y,U)'=-1

                       SET %=+Y

               End DoDot:1

               IF %=""

                   GOTO CLEX

               IF %

                   GOTO LEXC

 +38      ;display all codes and call reader

 +39       SET APCDANS=""

 +40       DO GETANS^APCDAPOV

 +41       IF APCDY="^"

               WRITE !

               Begin DoDot:1

 +42      ;now check fileman

 +43      ;W !!,"now trying fileman lookup..."

 +44      ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="QME" D ^DIC K DIC

                   SET %=""

 +45      ;S %="" I $P(Y,U)'=-1 S %=+Y

               End DoDot:1

               IF %=""

                   GOTO CLEX

               IF %

                   GOTO LEXC

 +46       IF APCDY=""

               WRITE !

               Begin DoDot:1

 +47      ;now check fileman

 +48      ;W !!,"now trying fileman lookup..."

 +49      ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC

                   SET %=""

 +50      ;S %="" I $P(Y,U)'=-1 S %=+Y

               End DoDot:1

               IF %=""

                   GOTO CLEX

               IF %

                   GOTO LEXC

 +51       IF '$GET(APCDY)

               WRITE !

               Begin DoDot:1

 +52      ;now check fileman

 +53      ;W !!,"now trying fileman lookup..."

 +54      ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC

                   SET %=""

 +55      ;S %="" I $P(Y,U)'=-1 S %=+Y

               End DoDot:1

               IF %=""

                   GOTO CLEX

               IF %

                   GOTO LEXC

 +56       IF APCDIMP=1

               SET Y=$$ICDONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."))

 +57       IF APCDIMP=30

               SET Y=$$ONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."),"10D")