Routine: APCDLPOV

APCDLPOV ; IHS/CMI/LAB - POV LOOKUP ; 01 Apr 2015  3:19 PM

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

START ;

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

LEX ;EP - called from input template

 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(APCDT90=1!($G(APCDTIN9)):"  PLACE OF OCCURRENCE (E849-E849.9)",1:"  PLACE OF OCCURRENCE (Y92-Y92.9)")

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

 S DIR("??")=$S($G(APCDTIN9):"^D HELPPL9^AUPNSIC9",1:"^D HELPPL^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^APCDLPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDLPOV(+Y,LEXVDT)")

 I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDLPOV(+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

 .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 LEX

 I APCDY="" W ! G LEX

 I '$G(APCDY) W ! G LEX

 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(APCDDATE,"."),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

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:'$$CHKPL^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:'$$CHKPL91^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:'$$CHKPL^AUPNSICD($P(ALEXICD,U,1)) ""

Q 1

EDITPLA ;EP

 D EN^XBNEW("EDITPLA1^APCDLPOV","APCDTDA;APCDT90;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTNPV;APCDTNOG;APCDTFIE;APCDTDIA;APCDTIN9")

EDITPLA1 ;

 I $G(APCDTIN9)!($G(APCDT90)) S APCDTDIA="  PLACE OF OCCURRENCE (E849-E849.9)"

 E  S APCDTDIA="  PLACE OF OCCURRENCE (Y92-Y92.9)"

 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 PLEX

 S APCDD=""

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

 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

PI ;

 S APCDIMP=$$IMP^AUPNSICD(APCDD)

PLEX ;EP - called from input template

 ;reader call to get TEXT for code

 K DIR,APCDTDEL

 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 HELPPL9^AUPNSIC9",1:"^D HELPPL^AUPNSICH")

 S DIR("??")=$S($G(APCDTIN9):"^D HELPPL9^AUPNSIC9",1:"^D HELPPL^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 XITP

 I X=U S APCDTUPH=1 G XITP

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

 I Y="" G XITP

 S APCDUINP=Y

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

 S %=""

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

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

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

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

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

 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^APCDLPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDLPOV(+Y,LEXVDT)")

 I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDLPOV(+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 PLEX

 .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 PLEX

 I APCDY="" W ! G PLEX

 I '$G(APCDY) W ! G PLEX

 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 XITP

 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 XITP

LEXP ;

 S APCDTNPV="`"_+%

W !

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

APCDLPOV  ; IHS/CMI/LAB - POV LOOKUP ; 01 Apr 2015  3:19 PM

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

 +2       ;

START     ;

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

 +2        QUIT

LEX       ;EP - called from input template

 +1        SET APCDTPCC=""

           SET APCDINPE=1

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

 +3        IF $GET(APCDTIN9)

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

               SET APCDIMP=1

               GOTO LEX1

 +4        SET APCDD=""

 +5        IF $GET(APCDINAD)

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

               GOTO I

 +6        IF $GET(APCDVSIT)

               IF $DATA(^AUPNVSIT(APCDVSIT))

                   Begin DoDot:1

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

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

                               SET APCDD=$$DSCHDATE^APCLV(APCDVSIT)

                               QUIT

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

                   End DoDot:1

 +9        IF APCDD=""

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

 +10       IF APCDD=""

               SET APCDD=DT

 +11       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(APCDT90=1!($GET(APCDTIN9)):"  PLACE OF OCCURRENCE (E849-E849.9)",1:"  PLACE OF OCCURRENCE (Y92-Y92.9)")

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

 +7        SET DIR("??")=$SELECT($GET(APCDTIN9):"^D HELPPL9^AUPNSIC9",1:"^D HELPPL^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^APCDLPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDLPOV(+Y,LEXVDT)")

 +17       IF APCDIMP=30

               SET DIC("S")="I $$ICDONE1^APCDLPOV(+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)

               End DoDot:1

               GOTO LEX

 +23      ;display all codes and call reader

 +24       SET APCDANS=""

 +25       DO GETANS^APCDAPOV

 +26       IF APCDY="^"

               WRITE !

               GOTO LEX

 +27       IF APCDY=""

               WRITE !

               GOTO LEX

 +28       IF '$GET(APCDY)

               WRITE !

               GOTO LEX

 +29       IF APCDIMP=1

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

 +30       IF APCDIMP=30

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

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

 +32       IF $GET(Y)=""

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

               SET APCDTERR=1

               SET APCDTCLK=""

               GOTO XITL

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

 +34       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

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 '$$CHKPL^AUPNSICD($PIECE(ALEXICD,U,1))

               QUIT ""

 +9        QUIT 1

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 '$$CHKPL91^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 '$$CHKPL^AUPNSICD($PIECE(ALEXICD,U,1))

               QUIT ""

 +9        QUIT 1

EDITPLA   ;EP

 +1        DO EN^XBNEW("EDITPLA1^APCDLPOV","APCDTDA;APCDT90;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTNPV;APCDTNOG;APCDTFIE;APCDTDIA;APCDTIN9")

 +2        QUIT

EDITPLA1  ;

 +1        IF $GET(APCDTIN9)!($GET(APCDT90))

               SET APCDTDIA="  PLACE OF OCCURRENCE (E849-E849.9)"

 +2       IF '$TEST

               SET APCDTDIA="  PLACE OF OCCURRENCE (Y92-Y92.9)"

 +3        SET APCDTPCC=""

           SET APCDINPE=1

 +4        KILL DIR

 +5        SET APCDTPCC=""

           SET APCDINPE=1

           SET APCDTNPV=""

           SET APCDTNOG=""

 +6        IF $GET(APCDTIN9)

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

               SET APCDIMP=1

               GOTO PLEX

 +7        SET APCDD=""

 +8        IF $GET(APCDINAD)

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

               GOTO PI

 +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

PI        ;

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

PLEX      ;EP - called from input template

 +1       ;reader call to get TEXT for code

 +2        KILL DIR,APCDTDEL

 +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 HELPPL9^AUPNSIC9",1:"^D HELPPL^AUPNSICH")

 +8        SET DIR("??")=$SELECT($GET(APCDTIN9):"^D HELPPL9^AUPNSIC9",1:"^D HELPPL^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 XITP

 +12       IF X=U

               SET APCDTUPH=1

               GOTO XITP

 +13       IF $DATA(DIRUT)

               SET APCDTSKI=1

               GOTO XITP

 +14       IF Y=""

               GOTO XITP

 +15       SET APCDUINP=Y

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

               GOTO XITP

 +17       SET %=""

 +18       IF APCDUINP=".9999"

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

               GOTO LEXP

 +19       IF APCDIMP=30

               IF APCDUINP="ZZZ.999"

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

                   GOTO LEXP

 +20       IF APCDIMP=30

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

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

                   GOTO LEXP

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

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

               GOTO LEXP

 +22       IF APCDUINP["UNCODED D"

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

               GOTO LEXP

 +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^APCDLPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDLPOV(+Y,LEXVDT)")

 +28       IF APCDIMP=30

               SET DIC("S")="I $$ICDONE1^APCDLPOV(+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)

               End DoDot:1

               GOTO PLEX

 +34      ;display all codes and call reader

 +35       SET APCDANS=""

 +36       DO GETANS^APCDAPOV

 +37       IF APCDY="^"

               WRITE !

               GOTO PLEX

 +38       IF APCDY=""

               WRITE !

               GOTO PLEX

 +39       IF '$GET(APCDY)

               WRITE !

               GOTO PLEX

 +40       IF APCDIMP=1

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

 +41       IF APCDIMP=30

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

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

 +43       IF $GET(Y)=""

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

               SET APCDTERR=1

               SET APCDTNPV=""

               GOTO XITP

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

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

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

               SET APCDTERR=1

               SET APCDTNPV=""

               GOTO XITP

LEXP      ;

 +1        SET APCDTNPV="`"_+%

 +2        WRITE !

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

 +1        QUIT

APCDLPOV.m