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
