APCDAOP.m

APCDAOP ; IHS/CMI/LAB - PROMPT FOR PROCEDURE ;

 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 ;

START ;

 S (APCDLOOK,APCDTNQP)=""

 D EN^XBNEW("START1^APCDAOP","APCDTSKI;APCDLOOK;APCDDATE;APCDTERR;APCDPAT;DFN;APCDTNQP;APCDTPCC;APCDTDIA;APCDVSIT;APCDTIN9")

 Q

START1 ;EP

 S APCDTPCC="",APCDINPE=1,APCDUINP=""

 K APCDTERR,APCDTSKI S APCDLOOK=""

 S APCDCAT=""

 I $G(APCDVSIT) S APCDCAT=$P(^AUPNVSIT(APCDVSIT,0),U,7)

 I APCDCAT="" S APCDCAT="A"

 NEW %,APCDD

 S APCDD=""

 I $G(APCDTIN9) S APCDD=$$FMADD^XLFDT($$IMP^ICDEX(31),-2),APCDIMP=2 G N

 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

 I $P($G(APCDPARM),U,21)="C",$G(APCDCAT)'="H" G CPT

I S APCDIMP=$$IMPOP^AUPNSICD(APCDD)

 ;I APCDIMP=31 G LEX1  ;CALL LEXICON FOR ICD10 ONLY

N K DIR

 ;G LEX1

 K APCDTERR,APCDTSKI S APCDLOOK=""

 S DIR(0)="FO^1:60",DIR("A")=$S($G(APCDTDIA)]"":APCDTDIA,1:"Enter OPERATION/PROCEDURE")

 S DIR("?")=$S(APCDIMP=31:"^D HELPOP^AUPNSICD",1:"^D HELPOP9^AUPNSIC9")

 KILL DA D ^DIR KILL DIR

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

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

 S APCDUINP=Y

 K DIC

 S APCDTNQP=""

 S X=APCDUINP

 I $G(APCDTIN9) X:$D(^DD(9000010.08,.22,12.1)) ^DD(9000010.08,.22,12.1)

 I '$G(APCDTIN9) X:$D(^DD(9000010.08,.01,12.1)) ^DD(9000010.08,.01,12.1)

 S DIC="^ICD0(",DIC(0)="EMQZ",DIC("A")="Enter OPERATION/PROCEDURE: ",DIC("W")="D EN^DDIOL($P($$ICDOP^ICDEX(Y,$S($G(APCDD):APCDD,1:DT),,""I""),U,5)"

 D ^DIC K DIC

 G:Y="" XIT

 I $P(Y,U)=-1,X="" W !!,"Code not selected." S APCDTERR=1,APCDLOOK="" G XIT

 I $P(Y,U)=-1,X="^" S APCDTSKI=1,APCDLOOK="" G N

 I $P(Y,U)=-1 S APCDTERR=1,APCDLOOK="" G N

 S APCDLOOK="`"_+Y,APCDTNQP=$S($E(APCDUINP)="`":"",1:APCDUINP) ;,APCDTNQP=X

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

 Q

 ;

CPT ;EP

 S APCDTPCC=""

 X:$D(^DD(9000010.08,.16,12.1)) ^DD(9000010.08,.16,12.1) S DIC="^ICPT(",DIC(0)="AEMQ",DIC("A")="Enter CPT CODE:  " D ^DIC K DIC

 G:Y="" XIT

 I Y=-1,X=""!(X="^") S APCDTSKI=1,APCDLOOK="" G XIT

 I Y=-1 S APCDTERR=1,APCDLOOK="" G XIT

 S APCDCPT=+Y

 I '$O(^ICPT(+Y,"ICD","B",0)) W !!,$C(7),$C(7),"No ICD Operation Match for that code - notify supervisor.",! S APCDTERR=1,APCDLOOK="",APCDCPT="" G XIT

 S APCDLOOK=$O(^ICPT(+Y,"ICD","B",0))

 I APCDLOOK="" W !!,$C(7),$C(7),"No ICD Operation Match for that code - notify supervisor.",! S APCDTERR=1,APCDLOOK="",APCDCPT="" G XIT

 I $P(^ICD0(APCDLOOK,0),U,9) W !!,$C(7),$C(7),"The ICD Operation code this CPT maps to is INACTIVE (",$P(^ICD0(APCDLOOK,0),U),") - cannot use!",! S APCDTERR="",APCDLOOK="",APCDCPT="" G XIT

 S APCDLOOK="`"_APCDLOOK

 D XIT

 Q

ICDONE(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=$$P10ONE^LEXU(ALEX,ALEXVDT) Q:ALEX="" ""

 S ALEXICD=$$ICDOP^ICDEX(ALEX,ALEXVDT,31,"E")

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

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

 Q 1

LEX1 ;EP - called from input template

 ;reader call to get TEXT for code

 K DIR

 S LEX=""

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

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

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

 S DIR(0)="FO^1:60",DIR("A")=$S($G(APCDTDIA)]"":APCDTDIA,1:"Enter OPERATION/PROCEDURE")

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

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

 KILL DA D ^DIR KILL DIR

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

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

 S APCDUINP=Y

 S %=""

 I APCDUINP=".9999" S %=+$$ICDOP^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ999"),$P(APCDD,"."),APCDIMP,"E") G LEXN1

 I APCDIMP=31,APCDUINP="ZZZ999" S %=+$$ICDOP^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ999"),$P(APCDD,"."),31,"E") G LEXN1

 I APCDIMP=31,$E(APCDUINP,1,3)="ZZZ" S %=+$$ICDOP^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ999"),$P(APCDD,"."),APCDIMP,"E") G LEXN1

 I $E(APCDUINP,1,7)="UNCODED" S %=+$$ICDOP^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ999"),$P(APCDD,"."),APCDIMP,"E") G LEXN1

 I APCDUINP["UNCODED D" S %=+$$ICDOP^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ999"),$P(APCDD,"."),APCDIMP,"E") G LEXN1

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

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

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

 S X=APCDUINP

 ;I APCDIMP=2 S DIC("S")=$S('$G(APCDTIN9):"I $$ICDONE^APCDAOP(+Y,LEXVDT)",1:"I $$ICDONE^APCDAOP(+Y,LEXVDT)")

 ;I APCDIMP=31 S DIC("S")="I $$ICDONE^APCDAOP(+Y,LEXVDT)"

 S DIC("A")="Enter OPERATION/PROCEDURE: "

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

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

 I 'LEX D  G LEX1

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

 ;display all codes and call reader

 S APCDANS=""

 D GETANS^APCDAPOV

 I APCDY="^" W ! G LEX1

 I APCDY="" W ! G LEX1

 I '$G(APCDY) W ! G LEX1

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

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

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

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

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

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

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

LEXN1 ;

 S APCDLOOK="`"_+%,APCDTNQP=APCDUINP

 W !

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

 Q

DUAL(APCDDDA,APCDDVS,APCDDDF,APCDDDFE,APCDDDL,APCDDDS) ;EP - CALLED FROM INPUT TEMPLATES

 D EN^XBNEW("ENDUAL^APCDAOP","APCDDDA;APCDDVS;APCDDDF;APCDDDFE;APCDDDL;APCDDDS")

 K APCDDDA

 W !

 Q

ENDUAL ;

 S APCDTIN9=1

 W !!,"For dual coding."

 S APCDTDIA=APCDDDL

 S APCDVSIT=APCDDVS

 S APCDDATE=$$VD^APCLV(APCDDVS)

 ;W !

 I APCDDDS=80.1 D START1^APCDAOP

 I APCDDDS=80 D START1^APCDAPOV

 I APCDLOOK]"" S DIE=APCDDDF,DA=APCDDDA,DR=APCDDDFE_"///"_APCDLOOK D ^DIE K DA,DR,DIE Q

 W !!,"You did not enter an ICD-9 code.",!

 S DIR(0)="Y",DIR("A")="Do you wish to try again",DIR("B")="N" KILL DA D ^DIR KILL DIR

 I 'Y Q

 I $D(DIRUT) Q

 G ENDUAL

TEST ;

 K ^TMP("LEXSCH",$J)

 D CONFIG^LEXSET("10P","10P",DT)

 D LOOK^LEXA("UNCODED","10P",999,"10P",DT)

 Q

APCDAOP   ; IHS/CMI/LAB - PROMPT FOR PROCEDURE ;

 +1       ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 +2       ;

START     ;

 +1        SET (APCDLOOK,APCDTNQP)=""

 +2        DO EN^XBNEW("START1^APCDAOP","APCDTSKI;APCDLOOK;APCDDATE;APCDTERR;APCDPAT;DFN;APCDTNQP;APCDTPCC;APCDTDIA;APCDVSIT;APCDTIN9")

 +3        QUIT 

START1    ;EP

 +1        SET APCDTPCC=""

           SET APCDINPE=1

           SET APCDUINP=""

 +2        KILL APCDTERR,APCDTSKI

           SET APCDLOOK=""

 +3        SET APCDCAT=""

 +4        IF $GET(APCDVSIT)

               SET APCDCAT=$PIECE(^AUPNVSIT(APCDVSIT,0),U,7)

 +5        IF APCDCAT=""

               SET APCDCAT="A"

 +6        NEW %,APCDD

 +7        SET APCDD=""

 +8        IF $GET(APCDTIN9)

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

               SET APCDIMP=2

               GOTO N

 +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       IF $PIECE($GET(APCDPARM),U,21)="C"

               IF $GET(APCDCAT)'="H"

                   GOTO CPT

I          SET APCDIMP=$$IMPOP^AUPNSICD(APCDD)

 +1       ;I APCDIMP=31 G LEX1  ;CALL LEXICON FOR ICD10 ONLY

N          KILL DIR

 +1       ;G LEX1

 +2        KILL APCDTERR,APCDTSKI

           SET APCDLOOK=""

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

           SET DIR("A")=$SELECT($GET(APCDTDIA)]"":APCDTDIA,1:"Enter OPERATION/PROCEDURE")

 +4        SET DIR("?")=$SELECT(APCDIMP=31:"^D HELPOP^AUPNSICD",1:"^D HELPOP9^AUPNSIC9")

 +5        KILL DA

           DO ^DIR

           KILL DIR

 +6        IF $DATA(DIRUT)

               SET APCDTSKI=1

               SET APCDLOOK=""

               GOTO XIT

 +7        IF Y=""

               SET APCDTSKI=1

               SET APCDLOOK=""

               GOTO XIT

 +8        SET APCDUINP=Y

 +9        KILL DIC

 +10       SET APCDTNQP=""

 +11       SET X=APCDUINP

 +12       IF $GET(APCDTIN9)

               IF $DATA(^DD(9000010.08,.22,12.1))

                   XECUTE ^DD(9000010.08,.22,12.1)

 +13       IF '$GET(APCDTIN9)

               IF $DATA(^DD(9000010.08,.01,12.1))

                   XECUTE ^DD(9000010.08,.01,12.1)

 +14       SET DIC="^ICD0("

           SET DIC(0)="EMQZ"

           SET DIC("A")="Enter OPERATION/PROCEDURE: "

           SET DIC("W")="D EN^DDIOL($P($$ICDOP^ICDEX(Y,$S($G(APCDD):APCDD,1:DT),,""I""),U,5)"

 +15       DO ^DIC

           KILL DIC

 +16       IF Y=""

               GOTO XIT

 +17       IF $PIECE(Y,U)=-1

               IF X=""

                   WRITE !!,"Code not selected."

                   SET APCDTERR=1

                   SET APCDLOOK=""

                   GOTO XIT

 +18       IF $PIECE(Y,U)=-1

               IF X="^"

                   SET APCDTSKI=1

                   SET APCDLOOK=""

                   GOTO N

 +19       IF $PIECE(Y,U)=-1

               SET APCDTERR=1

               SET APCDLOOK=""

               GOTO N

 +20      ;,APCDTNQP=X

           SET APCDLOOK="`"_+Y

           SET APCDTNQP=$SELECT($EXTRACT(APCDUINP)="`":"",1:APCDUINP)

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

 +1        QUIT 

 +2       ;

CPT       ;EP

 +1        SET APCDTPCC=""

 +2        IF $DATA(^DD(9000010.08,.16,12.1))

               XECUTE ^DD(9000010.08,.16,12.1)

           SET DIC="^ICPT("

           SET DIC(0)="AEMQ"

           SET DIC("A")="Enter CPT CODE:  "

           DO ^DIC

           KILL DIC

 +3        IF Y=""

               GOTO XIT

 +4        IF Y=-1

               IF X=""!(X="^")

                   SET APCDTSKI=1

                   SET APCDLOOK=""

                   GOTO XIT

 +5        IF Y=-1

               SET APCDTERR=1

               SET APCDLOOK=""

               GOTO XIT

 +6        SET APCDCPT=+Y

 +7        IF '$ORDER(^ICPT(+Y,"ICD","B",0))

               WRITE !!,$CHAR(7),$CHAR(7),"No ICD Operation Match for that code - notify supervisor.",!

               SET APCDTERR=1

               SET APCDLOOK=""

               SET APCDCPT=""

               GOTO XIT

 +8        SET APCDLOOK=$ORDER(^ICPT(+Y,"ICD","B",0))

 +9        IF APCDLOOK=""

               WRITE !!,$CHAR(7),$CHAR(7),"No ICD Operation Match for that code - notify supervisor.",!

               SET APCDTERR=1

               SET APCDLOOK=""

               SET APCDCPT=""

               GOTO XIT

 +10       IF $PIECE(^ICD0(APCDLOOK,0),U,9)

               WRITE !!,$CHAR(7),$CHAR(7),"The ICD Operation code this CPT maps to is INACTIVE (",$PIECE(^ICD0(APCDLOOK,0),U),") - cannot use!",!

               SET APCDTERR=""

               SET APCDLOOK=""

               SET APCDCPT=""

               GOTO XIT

 +11       SET APCDLOOK="`"_APCDLOOK

 +12       DO XIT

 +13       QUIT 

ICDONE(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=$$P10ONE^LEXU(ALEX,ALEXVDT)

           IF ALEX=""

               QUIT ""

 +6        SET ALEXICD=$$ICDOP^ICDEX(ALEX,ALEXVDT,31,"E")

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

               QUIT ""

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

               QUIT ""

 +9        QUIT 1

LEX1      ;EP - called from input template

 +1       ;reader call to get TEXT for code

 +2        KILL DIR

 +3        SET LEX=""

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

 +5       ;I APCDIMP=2 D CONFIG^LEXSET(1,"PL2",$P(APCDD,"."))

 +6        IF APCDIMP=31

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

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

           SET DIR("A")=$SELECT($GET(APCDTDIA)]"":APCDTDIA,1:"Enter OPERATION/PROCEDURE")

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

 +9        SET DIR("??")=$SELECT($GET(APCDTIN9):"^D HELPOP9^AUPNSIC9",1:"^D HELPOP^AUPNSICH")

 +10       KILL DA

           DO ^DIR

           KILL DIR

 +11       IF $DATA(DIRUT)

               SET APCDTSKI=1

               SET APCDLOOK=""

               GOTO XITL1

 +12       IF Y=""

               SET APCDTSKI=1

               SET APCDLOOK=""

               GOTO XITL1

 +13       SET APCDUINP=Y

 +14       SET %=""

 +15       IF APCDUINP=".9999"

               SET %=+$$ICDOP^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ999"),$PIECE(APCDD,"."),APCDIMP,"E")

               GOTO LEXN1

 +16       IF APCDIMP=31

               IF APCDUINP="ZZZ999"

                   SET %=+$$ICDOP^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ999"),$PIECE(APCDD,"."),31,"E")

                   GOTO LEXN1

 +17       IF APCDIMP=31

               IF $EXTRACT(APCDUINP,1,3)="ZZZ"

                   SET %=+$$ICDOP^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ999"),$PIECE(APCDD,"."),APCDIMP,"E")

                   GOTO LEXN1

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

               SET %=+$$ICDOP^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ999"),$PIECE(APCDD,"."),APCDIMP,"E")

               GOTO LEXN1

 +19       IF APCDUINP["UNCODED D"

               SET %=+$$ICDOP^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ999"),$PIECE(APCDD,"."),APCDIMP,"E")

               GOTO LEXN1

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

 +21      ;I APCDIMP=2 D CONFIG^LEXSET(1,"PL2",$P(APCDD,"."))

 +22       IF APCDIMP=31

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

 +23       SET X=APCDUINP

 +24      ;I APCDIMP=2 S DIC("S")=$S('$G(APCDTIN9):"I $$ICDONE^APCDAOP(+Y,LEXVDT)",1:"I $$ICDONE^APCDAOP(+Y,LEXVDT)")

 +25      ;I APCDIMP=31 S DIC("S")="I $$ICDONE^APCDAOP(+Y,LEXVDT)"

 +26       SET DIC("A")="Enter OPERATION/PROCEDURE: "

 +27      ;I APCDIMP=2 D LOOK^LEXA(X,1,999,"PL2",$P(APCDD,"."))

 +28       IF APCDIMP=31

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

 +29       IF 'LEX

               Begin DoDot:1

 +30               SET X=0

                   FOR 

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

                       IF X'=+X

                           QUIT 

                       WRITE !,LEX("HLP",X)

               End DoDot:1

               GOTO LEX1

 +31      ;display all codes and call reader

 +32       SET APCDANS=""

 +33       DO GETANS^APCDAPOV

 +34       IF APCDY="^"

               WRITE !

               GOTO LEX1

 +35       IF APCDY=""

               WRITE !

               GOTO LEX1

 +36       IF '$GET(APCDY)

               WRITE !

               GOTO LEX1

 +37      ;I APCDIMP=2 S Y=$$ICDONE^LEXUTHORTOTHOTHOR($P(^TMP("LEXHIT",$J,APCDY),U,1),$P(APCDD,"."))

 +38       IF APCDIMP=31

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

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

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

 +41       IF $GET(Y)=""

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

               SET APCDTERR=1

               SET APCDLOOK=""

               GOTO XITL1

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

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

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

               SET APCDTERR=1

               SET APCDLOOK=""

               GOTO XITL1

LEXN1     ;

 +1        SET APCDLOOK="`"_+%

           SET APCDTNQP=APCDUINP

 +2        WRITE !

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

 +1        QUIT 

DUAL(APCDDDA,APCDDVS,APCDDDF,APCDDDFE,APCDDDL,APCDDDS) ;EP - CALLED FROM INPUT TEMPLATES

 +1        DO EN^XBNEW("ENDUAL^APCDAOP","APCDDDA;APCDDVS;APCDDDF;APCDDDFE;APCDDDL;APCDDDS")

 +2        KILL APCDDDA

 +3        WRITE !

 +4        QUIT 

ENDUAL    ;

 +1        SET APCDTIN9=1

 +2        WRITE !!,"For dual coding."

 +3        SET APCDTDIA=APCDDDL

 +4        SET APCDVSIT=APCDDVS

 +5        SET APCDDATE=$$VD^APCLV(APCDDVS)

 +6       ;W !

 +7        IF APCDDDS=80.1

               DO START1^APCDAOP

 +8        IF APCDDDS=80

               DO START1^APCDAPOV

 +9        IF APCDLOOK]""

               SET DIE=APCDDDF

               SET DA=APCDDDA

               SET DR=APCDDDFE_"///"_APCDLOOK

               DO ^DIE

               KILL DA,DR,DIE

               QUIT 

 +10       WRITE !!,"You did not enter an ICD-9 code.",!

 +11       SET DIR(0)="Y"

           SET DIR("A")="Do you wish to try again"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +12       IF 'Y

               QUIT 

 +13       IF $DATA(DIRUT)

               QUIT 

 +14       GOTO ENDUAL

TEST      ;

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

 +2        DO CONFIG^LEXSET("10P","10P",DT)

 +3        DO LOOK^LEXA("UNCODED","10P",999,"10P",DT)

 +4        QUIT