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")
+58 KILL DO,^TMP("LEXSCH",$JOB)
+59 IF $GET(Y)=""
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDTNPV=""
GOTO XITC
+60 SET %=$$ICDDX^ICDEX(Y,$PIECE(APCDD,"."),APCDIMP,"E")
+61 IF $PIECE(%,U,1)="-1"
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDTNPV=""
GOTO XITC
LEXC ;
+1 SET APCDTNPV="`"_+%
+2 WRITE !
XITC KILL Y,X,DO,D,DD,DIPGM,APCDTPCC
+1 QUIT