APCDAPOV ; IHS/CMI/LAB - POV LOOKUP ; 13 Feb 2014 2:26 PM
;;2.0;IHS PCC SUITE;**10,11,13,20**;MAY 14, 2009;Build 25
;
START ;
S (APCDLOOK,APCDTNQP)=""
D EN^XBNEW("START1^APCDAPOV","APCDTSKI;APCDLOOK;APCDDATE;APCDTERR;APCDPAT;DFN;APCDTNQP;APCDTPCC;APCDTDIA;APCDVSIT;APCDINAD,APCDTIN9")
Q
START1 ;EP
S APCDTPCC="",APCDINPE=1
I $G(APCDTIN9) S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1 G LEX
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)
LEX ;EP - called from input template
;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 HELP9^AUPNSIC9",1:"^D HELP^AUPNSICH")
S DIR("??")=$S($G(APCDTIN9):"^D HELP9^AUPNSIC9",1:"^D HELP^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
S %=""
I APCDUINP=".9999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999"),,APCDIMP,"E") G LEXN
I APCDIMP=30,APCDUINP="ZZZ.999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
I APCDIMP=30,$E(APCDUINP,1,4)="ZZZ." S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
I $E(APCDUINP,1,7)="UNCODED" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
I APCDUINP["UNCODED D" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
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^APCDAPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDAPOV(+Y,LEXVDT)")
I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDAPOV(+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 ^AUPNSICD" D ^DIC K DIC
.S %="" I $P(Y,U)'=-1 S %=+Y
;display all codes and call reader
S APCDANS=""
D GETANS
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,APCDLOOK="" G XITL
S %=$$ICDDX^ICDEX(Y,$P(APCDD,"."),,"E")
I $P(%,U,1)="-1" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDLOOK="" G XITL
LEXN ;
S APCDLOOK="`"_+%,APCDTNQP=APCDUINP
W !
XITL K Y,X,DO,D,DD,DIPGM,APCDTPCC
Q
CAUSE(C,S) ;EP
;C IS IEN, S IS CODING SYSTEM
S C=$P($$ICDDX^ICDEX(C,,,"I"),U,2)
NEW %
S %=0
I S=1 D Q %
.I $E(C,1)="E" S %=1 Q
I $E(C,1)="V" S %=1 ;only codes V00-Y99 per Leslie Racine.
I $E(C,1)="W" S %=1
I $E(C,1)="X" S %=1
I $E(C,1)="Y" S %=1
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
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:'$$CHK^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:'$$CHK91^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,ALEVXDT,%
S ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D") Q:ALEX="" ""
S ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,30,"E")
Q:$P(ALEXICD,"^",2)="INVALID CODE" ""
Q:'$$CHK^AUPNSICD($P(ALEXICD,U,1)) ""
Q 1
TEST10 ;
K ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST")
K LEX
S APCDDATE=DT
D CONFIG^LEXSET("10D","10D",$S(APCDDATE>3141001:APCDDATE,1:3141001))
S DIC("S")="I $$ICDONE1^APCDAPOV(+Y,LEXVDT)"
S APCDDATE=DT
D LOOK^LEXA("HYPERTENSION","10D",999,"10D",$S(APCDDATE>3141001:APCDDATE,1:3141001))
;ZW LEX
Q
GETANS ;EP - DISPLAY LEX ARRAY
NEW APCDX,APCDZ,APCDQ,APCDCNT,APCDTOT,Z,MF
S MF=$P(^TMP("LEXHIT",$J,0),U)
W !!?5,$P(^TMP("LEXHIT",$J,0),U)," term matches found.",!
S APCDX=0,APCDY="",APCDQ=0,APCDCNT=0,APCDTOT=0
F S APCDX=$O(^TMP("LEXHIT",$J,APCDX)) Q:APCDX'=+APCDX!(APCDY]"") D
DISP .;display code
.K ^UTILITY($J,"W")
.W !?3,APCDX,")"
.S APCDZ=$P(^TMP("LEXHIT",$J,APCDX),U,2)
.I APCDZ'["(ICD-" S APCDZ=APCDZ_" (ICD-"_$S(APCDIMP=1:9,1:10)_"-CM "_$$ONE^LEXU($P(^TMP("LEXHIT",$J,APCDX),U,1),LEXVDT,$S(APCDIMP=1:"ICD",1:"10D"))_")"
.S X=APCDZ,DIWL=0,DIWR=70 D ^DIWP
.S Z=0 F S Z=$O(^UTILITY($J,"W",0,Z)) Q:Z'=+Z W:Z>1 ! W ?9,^UTILITY($J,"W",0,Z,0)
.; APCDCNT=APCDCNT+1,APCDTOT=APCDTOT+1
.S APCDCNT=APCDCNT+1,APCDTOT=APCDTOT+1
.I MF=1 S APCDCNT=1,APCDTOT=1 D READ S:APCDY="" APCDY="^" Q
.I MF>4,APCDCNT=5!(MF=APCDTOT) D READ S APCDCNT=0 Q
.I MF<5,MF=APCDX D READ S APCDNT=0 Q:APCDY]""
.Q
Q
READ ;
K DIR,DIRUT
S APCDY=""
W !
;W !,"Type ""^"" to STOP, press ENTER to continue the list or SELECT 1-"_APCDTOT
S DIR("B")=$S(MF=1:1,1:""),DIR(0)="NO^1:"_APCDTOT_":0"
S DIR("A")="Type ""^"" to STOP or SELECT 1-"_APCDTOT
KILL DA D ^DIR W !
I $D(DIRUT) S APCDY="^"
I Y="" S APCDY="" Q
S APCDY=+Y
Q
OLD ;EP - called from CPV input template
I $G(APCDTDIA)["PROBLEM" D START^APCDAPRB Q
S APCDTPCC=""
X:$D(^DD(9000010.07,.01,12.1)) ^DD(9000010.07,.01,12.1) S DIC="^ICD9(",DIC(0)="AEMQ",DIC("A")="Enter PURPOSE of VISIT: " 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 APCDLOOK="`"_+Y,APCDTNQP=X
XIT K Y,X,DO,D,DD,DIPGM,APCDTPCC
Q
CINJ ;GET CAUSE OF INJURY CODES FROM LEXICON
K ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST"),LEX
D CONFIG^LEXSET("10D","10D",DT)
S DIC("S")="I $$ICDCIJ^APCDAPOV(+Y,LEXVDT)"
D LOOK^LEXA("FALL","10D",999,"10D",DT)
Q
ICDCIJ(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,ALEVXDT,%
S ALEX=$$ONE^LEXU(ALEX,DT,"10D") Q:ALEX="" ""
S ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT)
Q:$P(ALEXICD,"^",2)="INVALID CODE" ""
Q:'$$CAUSE($P(ALEXICD,U,2),30) ""
Q 1
GETICD ;
S Y=$$ONE^LEXU($P(LEX("LIST",73),U,1),DT,"10D")
W !,Y
Q
APCDAPOV ; IHS/CMI/LAB - POV LOOKUP ; 13 Feb 2014 2:26 PM
+1 ;;2.0;IHS PCC SUITE;**10,11,13,20**;MAY 14, 2009;Build 25
+2 ;
START ;
+1 SET (APCDLOOK,APCDTNQP)=""
+2 DO EN^XBNEW("START1^APCDAPOV","APCDTSKI;APCDLOOK;APCDDATE;APCDTERR;APCDPAT;DFN;APCDTNQP;APCDTPCC;APCDTDIA;APCDVSIT;APCDINAD,APCDTIN9")
+3 QUIT
START1 ;EP
+1 SET APCDTPCC=""
SET APCDINPE=1
+2 IF $GET(APCDTIN9)
SET APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2)
SET APCDIMP=1
GOTO LEX
+3 SET APCDD=""
+4 IF $GET(APCDINAD)
SET APCDD=$SELECT($DATA(APCDDATE):APCDDATE,1:DT)
GOTO I
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET APCDD=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+7 SET APCDD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+8 IF APCDD=""
SET APCDD=$PIECE($GET(APCDDATE),".")
+9 IF APCDD=""
SET APCDD=DT
+10 NEW APCDIMP,APCDANS
I ;
+1 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
LEX ;EP - called from input template
+1 ;reader call to get TEXT for code
+2 KILL DIR
+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")=$SELECT($GET(APCDTDIA)]"":APCDTDIA,1:"Enter PURPOSE OF VISIT")
+7 SET DIR("?")=$SELECT($GET(APCDTIN9):"^D HELP9^AUPNSIC9",1:"^D HELP^AUPNSICH")
+8 SET DIR("??")=$SELECT($GET(APCDTIN9):"^D HELP9^AUPNSIC9",1:"^D HELP^AUPNSICH")
+9 KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
SET APCDTSKI=1
SET APCDLOOK=""
GOTO XITL
+11 IF Y=""
SET APCDTSKI=1
SET APCDLOOK=""
GOTO XITL
+12 SET APCDUINP=Y
+13 SET %=""
+14 IF APCDUINP=".9999"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),,APCDIMP,"E")
GOTO LEXN
+15 IF APCDIMP=30
IF APCDUINP="ZZZ.999"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+16 IF APCDIMP=30
IF $EXTRACT(APCDUINP,1,4)="ZZZ."
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+17 IF $EXTRACT(APCDUINP,1,7)="UNCODED"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+18 IF APCDUINP["UNCODED D"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+19 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXHIT",$JOB),LEX,^TMP("LEXFND",$JOB)
+20 IF APCDIMP=1
DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDD,"."))
+21 IF APCDIMP=30
DO CONFIG^LEXSET("10D","10D",$PIECE(APCDD,"."))
+22 SET X=APCDUINP
+23 IF APCDIMP=1
SET DIC("S")=$SELECT('$GET(APCDTIN9):"I $$ICDONE9^APCDAPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDAPOV(+Y,LEXVDT)")
+24 IF APCDIMP=30
SET DIC("S")="I $$ICDONE1^APCDAPOV(+Y,LEXVDT)"
+25 SET DIC("A")=$SELECT($GET(APCDTDIA)]"":APCDTDIA_": ",1:"Enter PURPOSE OF VISIT: ")
+26 IF APCDIMP=1
DO LOOK^LEXA(X,"ICD",999,"ICD",$PIECE(APCDD,"."))
+27 IF APCDIMP=30
DO LOOK^LEXA(X,"10D",999,"10D",$PIECE(APCDD,"."))
+28 IF 'LEX
Begin DoDot:1
+29 SET X=0
FOR
SET X=$ORDER(LEX("HLP",X))
IF X'=+X
QUIT
WRITE !,LEX("HLP",X)
+30 ;now check fileman V2.0 PATCH 20 CR#554
+31 WRITE !!,"now trying secondary fileman lookup..."
+32 SET %=""
SET X=APCDUINP
SET DIC="^ICD9("
SET DIC(0)="MEQ"
SET DIC("S")="D ^AUPNSICD"
DO ^DIC
KILL DIC
+33 SET %=""
IF $PIECE(Y,U)'=-1
SET %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+34 ;display all codes and call reader
+35 SET APCDANS=""
+36 DO GETANS
+37 IF APCDY="^"
WRITE !
Begin DoDot:1
+38 ;now check fileman
+39 ;W !!,"now trying fileman lookup..."
+40 ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="QME" D ^DIC K DIC
SET %=""
+41 ;S %="" I $P(Y,U)'=-1 S %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+42 IF APCDY=""
WRITE !
Begin DoDot:1
+43 ;now check fileman
+44 ;W !!,"now trying fileman lookup..."
+45 ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC
SET %=""
+46 ;S %="" I $P(Y,U)'=-1 S %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+47 IF '$GET(APCDY)
WRITE !
Begin DoDot:1
+48 ;now check fileman
+49 ;W !!,"now trying fileman lookup..."
+50 ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC
SET %=""
+51 ;S %="" I $P(Y,U)'=-1 S %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+52 IF APCDIMP=1
SET Y=$$ICDONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."))
+53 IF APCDIMP=30
SET Y=$$ONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."),"10D")
+54 KILL DO,^TMP("LEXSCH",$JOB)
+55 IF $GET(Y)=""
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDLOOK=""
GOTO XITL
+56 SET %=$$ICDDX^ICDEX(Y,$PIECE(APCDD,"."),,"E")
+57 IF $PIECE(%,U,1)="-1"
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDLOOK=""
GOTO XITL
LEXN ;
+1 SET APCDLOOK="`"_+%
SET APCDTNQP=APCDUINP
+2 WRITE !
XITL KILL Y,X,DO,D,DD,DIPGM,APCDTPCC
+1 QUIT
CAUSE(C,S) ;EP
+1 ;C IS IEN, S IS CODING SYSTEM
+2 SET C=$PIECE($$ICDDX^ICDEX(C,,,"I"),U,2)
+3 NEW %
+4 SET %=0
+5 IF S=1
Begin DoDot:1
+6 IF $EXTRACT(C,1)="E"
SET %=1
QUIT
End DoDot:1
QUIT %
+7 ;only codes V00-Y99 per Leslie Racine.
IF $EXTRACT(C,1)="V"
SET %=1
+8 IF $EXTRACT(C,1)="W"
SET %=1
+9 IF $EXTRACT(C,1)="X"
SET %=1
+10 IF $EXTRACT(C,1)="Y"
SET %=1
+11 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 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 '$$CHK^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 '$$CHK91^AUPNSIC9($PIECE(ALEXICD,U,1))
QUIT ""
+9 QUIT 1
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,ALEVXDT,%
+4 SET ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D")
IF ALEX=""
QUIT ""
+5 SET ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,30,"E")
+6 IF $PIECE(ALEXICD,"^",2)="INVALID CODE"
QUIT ""
+7 IF '$$CHK^AUPNSICD($PIECE(ALEXICD,U,1))
QUIT ""
+8 QUIT 1
TEST10 ;
+1 KILL ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST")
+2 KILL LEX
+3 SET APCDDATE=DT
+4 DO CONFIG^LEXSET("10D","10D",$SELECT(APCDDATE>3141001:APCDDATE,1:3141001))
+5 SET DIC("S")="I $$ICDONE1^APCDAPOV(+Y,LEXVDT)"
+6 SET APCDDATE=DT
+7 DO LOOK^LEXA("HYPERTENSION","10D",999,"10D",$SELECT(APCDDATE>3141001:APCDDATE,1:3141001))
+8 ;ZW LEX
+9 QUIT
GETANS ;EP - DISPLAY LEX ARRAY
+1 NEW APCDX,APCDZ,APCDQ,APCDCNT,APCDTOT,Z,MF
+2 SET MF=$PIECE(^TMP("LEXHIT",$JOB,0),U)
+3 WRITE !!?5,$PIECE(^TMP("LEXHIT",$JOB,0),U)," term matches found.",!
+4 SET APCDX=0
SET APCDY=""
SET APCDQ=0
SET APCDCNT=0
SET APCDTOT=0
+5 FOR
SET APCDX=$ORDER(^TMP("LEXHIT",$JOB,APCDX))
IF APCDX'=+APCDX!(APCDY]"")
QUIT
Begin DoDot:1
DISP ;display code
+1 KILL ^UTILITY($JOB,"W")
+2 WRITE !?3,APCDX,")"
+3 SET APCDZ=$PIECE(^TMP("LEXHIT",$JOB,APCDX),U,2)
+4 IF APCDZ'["(ICD-"
SET APCDZ=APCDZ_" (ICD-"_$SELECT(APCDIMP=1:9,1:10)_"-CM "_$$ONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDX),U,1),LEXVDT,$SELECT(APCDIMP=1:"ICD",1:"10D"))_")"
+5 SET X=APCDZ
SET DIWL=0
SET DIWR=70
DO ^DIWP
+6 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",0,Z))
IF Z'=+Z
QUIT
IF Z>1
WRITE !
WRITE ?9,^UTILITY($JOB,"W",0,Z,0)
+7 ; APCDCNT=APCDCNT+1,APCDTOT=APCDTOT+1
+8 SET APCDCNT=APCDCNT+1
SET APCDTOT=APCDTOT+1
+9 IF MF=1
SET APCDCNT=1
SET APCDTOT=1
DO READ
IF APCDY=""
SET APCDY="^"
QUIT
+10 IF MF>4
IF APCDCNT=5!(MF=APCDTOT)
DO READ
SET APCDCNT=0
QUIT
+11 IF MF<5
IF MF=APCDX
DO READ
SET APCDNT=0
IF APCDY]""
QUIT
+12 QUIT
End DoDot:1
+13 QUIT
READ ;
+1 KILL DIR,DIRUT
+2 SET APCDY=""
+3 WRITE !
+4 ;W !,"Type ""^"" to STOP, press ENTER to continue the list or SELECT 1-"_APCDTOT
+5 SET DIR("B")=$SELECT(MF=1:1,1:"")
SET DIR(0)="NO^1:"_APCDTOT_":0"
+6 SET DIR("A")="Type ""^"" to STOP or SELECT 1-"_APCDTOT
+7 KILL DA
DO ^DIR
WRITE !
+8 IF $DATA(DIRUT)
SET APCDY="^"
+9 IF Y=""
SET APCDY=""
QUIT
+10 SET APCDY=+Y
+11 QUIT
OLD ;EP - called from CPV input template
+1 IF $GET(APCDTDIA)["PROBLEM"
DO START^APCDAPRB
QUIT
+2 SET APCDTPCC=""
+3 IF $DATA(^DD(9000010.07,.01,12.1))
XECUTE ^DD(9000010.07,.01,12.1)
SET DIC="^ICD9("
SET DIC(0)="AEMQ"
SET DIC("A")="Enter PURPOSE of VISIT: "
DO ^DIC
KILL DIC
+4 IF Y=""
GOTO XIT
+5 IF Y=-1
IF X=""!(X="^")
SET APCDTSKI=1
SET APCDLOOK=""
GOTO XIT
+6 IF Y=-1
SET APCDTERR=1
SET APCDLOOK=""
GOTO XIT
+7 SET APCDLOOK="`"_+Y
SET APCDTNQP=X
XIT KILL Y,X,DO,D,DD,DIPGM,APCDTPCC
+1 QUIT
CINJ ;GET CAUSE OF INJURY CODES FROM LEXICON
+1 KILL ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST"),LEX
+2 DO CONFIG^LEXSET("10D","10D",DT)
+3 SET DIC("S")="I $$ICDCIJ^APCDAPOV(+Y,LEXVDT)"
+4 DO LOOK^LEXA("FALL","10D",999,"10D",DT)
+5 QUIT
ICDCIJ(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,ALEVXDT,%
+4 SET ALEX=$$ONE^LEXU(ALEX,DT,"10D")
IF ALEX=""
QUIT ""
+5 SET ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT)
+6 IF $PIECE(ALEXICD,"^",2)="INVALID CODE"
QUIT ""
+7 IF '$$CAUSE($PIECE(ALEXICD,U,2),30)
QUIT ""
+8 QUIT 1
GETICD ;
+1 SET Y=$$ONE^LEXU($PIECE(LEX("LIST",73),U,1),DT,"10D")
+2 WRITE !,Y
+3 QUIT
