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")
Q
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
Q
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")
Q
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
Q
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
