APCDETPD ; IHS/CMI/LAB - POV ICDUP ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
START ;
D EN^XBNEW("START1^APCDETPD","APCDTSKI;APCDTDX;APCDTERR;APCDPAT;APCDTDI")
Q
START1 ;EP
S APCDTPCC="",APCDINPE=1
S APCDD=APCDTDI
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")="Enter DIAGNOSIS"
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"),$P(APCDD,"."),APCDIMP,"E") G LEXN
I APCDIMP=30,APCDUINP="ZZZ.999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999"),$P(APCDD,"."),APCDIMP,"E") G LEXN
I APCDIMP=30,$E(APCDUINP,1,4)="ZZZ." S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999"),$P(APCDD,"."),APCDIMP,"E") G LEXN
I $E(APCDUINP,1,7)="UNCODED" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999"),$P(APCDD,"."),APCDIMP,"E") G LEXN
I APCDUINP["UNCODED D" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999"),$P(APCDD,"."),APCDIMP,"E") 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")="I $$ICDONE9^APCDETPD(+Y,LEXVDT)"
I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDETPD(+Y,LEXVDT)"
S DIC("A")="Enter DIAGNOSIS"
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,APCDLOOK="" 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,APCDLOOK="" G XITL
LEXN ;
S APCDTDX=+%
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=$$ONE^LEXSRC(ALEX,"ICD",ALEXVDT) Q:ALEX="" ""
S ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,1,"E")
Q:$P(ALEXICD,"^",2)="INVALID CODE" ""
Q:'$$CHK^AUPNCIX($P(ALEXICD,U,1),,APCDTDI) ""
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^AUPNCIX($P(ALEXICD,U,1),,APCDTDI) ""
Q 1
APCDETPD ; IHS/CMI/LAB - POV ICDUP ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
START ;
+1 DO EN^XBNEW("START1^APCDETPD","APCDTSKI;APCDTDX;APCDTERR;APCDPAT;APCDTDI")
+2 QUIT
START1 ;EP
+1 SET APCDTPCC=""
SET APCDINPE=1
+2 SET APCDD=APCDTDI
+3 IF APCDD=""
SET APCDD=DT
+4 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")="Enter DIAGNOSIS"
+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"),$PIECE(APCDD,"."),APCDIMP,"E")
GOTO LEXN
+15 IF APCDIMP=30
IF APCDUINP="ZZZ.999"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),$PIECE(APCDD,"."),APCDIMP,"E")
GOTO LEXN
+16 IF APCDIMP=30
IF $EXTRACT(APCDUINP,1,4)="ZZZ."
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),$PIECE(APCDD,"."),APCDIMP,"E")
GOTO LEXN
+17 IF $EXTRACT(APCDUINP,1,7)="UNCODED"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),$PIECE(APCDD,"."),APCDIMP,"E")
GOTO LEXN
+18 IF APCDUINP["UNCODED D"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),$PIECE(APCDD,"."),APCDIMP,"E")
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")="I $$ICDONE9^APCDETPD(+Y,LEXVDT)"
+24 IF APCDIMP=30
SET DIC("S")="I $$ICDONE1^APCDETPD(+Y,LEXVDT)"
+25 SET DIC("A")="Enter DIAGNOSIS"
+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)
End DoDot:1
GOTO LEX
+30 ;display all codes and call reader
+31 SET APCDANS=""
+32 DO GETANS^APCDAPOV
+33 IF APCDY="^"
WRITE !
GOTO LEX
+34 IF APCDY=""
WRITE !
GOTO LEX
+35 IF '$GET(APCDY)
WRITE !
GOTO LEX
+36 IF APCDIMP=1
SET Y=$$ICDONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."))
+37 IF APCDIMP=30
SET Y=$$ONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."),"10D")
+38 KILL DO,^TMP("LEXSCH",$JOB)
+39 IF $GET(Y)=""
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDLOOK=""
GOTO XITL
+40 SET %=$$ICDDX^ICDEX(Y,$PIECE(APCDD,"."),APCDIMP,"E")
+41 IF $PIECE(%,U,1)="-1"
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDLOOK=""
GOTO XITL
LEXN ;
+1 SET APCDTDX=+%
+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=$$ONE^LEXSRC(ALEX,"ICD",ALEXVDT)
IF ALEX=""
QUIT ""
+6 SET ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,1,"E")
+7 IF $PIECE(ALEXICD,"^",2)="INVALID CODE"
QUIT ""
+8 IF '$$CHK^AUPNCIX($PIECE(ALEXICD,U,1),,APCDTDI)
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^AUPNCIX($PIECE(ALEXICD,U,1),,APCDTDI)
QUIT ""
+8 QUIT 1
