APCDFHD ; IHS/CMI/LAB - POV ICDUP ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
START ;
D EN^XBNEW("START1^APCDFHD","APCDTSKI;APCDICD;APCDTERR;APCDPAT;APCDDATE")
Q
START1 ;EP
S APCDTPCC="",APCDINPE=1
;FOR NOW IF ICD9 CALL LEX, AFTER VA SENDS OUT ICD10 LEX JUST D LEX Q
NEW APCDCSI
S (APCDIMP,APCDCSI)=$$IMP^AUPNSICD($S($G(APCDDATE):$P(APCDDATE,"."),1:DT))
;
LEX ;EP - called from input template
K DIR
K ^TMP("LEXSCH",$J)
I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDDATE,"."))
I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$S(APCDDATE>3141001:APCDDATE,1:3141001))
S DIR(0)="FO^1:60",DIR("A")="Family History Condition"
S DIR("?")="^D HELPFH^AUPNSICD"
S DIR("??")="^D HELPFH^AUPNSICD"
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),LEX,^TMP("LEXHIT",$J),^TMP("LEXFND",$J)
I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDDATE,"."))
I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$S(APCDDATE>3141001:APCDDATE,1:3141001))
S X=APCDUINP
I APCDIMP=1 S DIC("S")="I $$ICDONE9^APCDFHD(+Y,LEXVDT)"
I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDFHD(+Y,LEXVDT)"
I APCDIMP=1 D LOOK^LEXA(X,"ICD",999,"ICD",$P(APCDDATE,".",1))
I APCDIMP=30 D LOOK^LEXA(X,"10D",999,"10D",$S(APCDDATE>3141001:APCDDATE,1:3141001))
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(APCDDATE,"."))
I APCDIMP=30 S Y=$$ONE^LEXU($P(^TMP("LEXHIT",$J,APCDY),U,1),$S($P(APCDDATE,".")>3141001:$P(APCDDATE,"."),1:3141001),"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
S APCDICD=$P(%,U,1)
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:'$$CHKFH^AUPNSICD($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)
Q:$P(ALEXICD,"^",2)="INVALID CODE" ""
Q:'$$CHKFH^AUPNSICD($P(ALEXICD,U,1)) ""
Q 1
APCDFHD ; IHS/CMI/LAB - POV ICDUP ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
START ;
+1 DO EN^XBNEW("START1^APCDFHD","APCDTSKI;APCDICD;APCDTERR;APCDPAT;APCDDATE")
+2 QUIT
START1 ;EP
+1 SET APCDTPCC=""
SET APCDINPE=1
+2 ;FOR NOW IF ICD9 CALL LEX, AFTER VA SENDS OUT ICD10 LEX JUST D LEX Q
+3 NEW APCDCSI
+4 SET (APCDIMP,APCDCSI)=$$IMP^AUPNSICD($SELECT($GET(APCDDATE):$PIECE(APCDDATE,"."),1:DT))
+5 ;
LEX ;EP - called from input template
+1 KILL DIR
+2 KILL ^TMP("LEXSCH",$JOB)
+3 IF APCDIMP=1
DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDDATE,"."))
+4 IF APCDIMP=30
DO CONFIG^LEXSET("10D","10D",$SELECT(APCDDATE>3141001:APCDDATE,1:3141001))
+5 SET DIR(0)="FO^1:60"
SET DIR("A")="Family History Condition"
+6 SET DIR("?")="^D HELPFH^AUPNSICD"
+7 SET DIR("??")="^D HELPFH^AUPNSICD"
+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),LEX,^TMP("LEXHIT",$JOB),^TMP("LEXFND",$JOB)
+13 IF APCDIMP=1
DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDDATE,"."))
+14 IF APCDIMP=30
DO CONFIG^LEXSET("10D","10D",$SELECT(APCDDATE>3141001:APCDDATE,1:3141001))
+15 SET X=APCDUINP
+16 IF APCDIMP=1
SET DIC("S")="I $$ICDONE9^APCDFHD(+Y,LEXVDT)"
+17 IF APCDIMP=30
SET DIC("S")="I $$ICDONE1^APCDFHD(+Y,LEXVDT)"
+18 IF APCDIMP=1
DO LOOK^LEXA(X,"ICD",999,"ICD",$PIECE(APCDDATE,".",1))
+19 IF APCDIMP=30
DO LOOK^LEXA(X,"10D",999,"10D",$SELECT(APCDDATE>3141001:APCDDATE,1:3141001))
+20 IF 'LEX
Begin DoDot:1
+21 SET X=0
FOR
SET X=$ORDER(LEX("HLP",X))
IF X'=+X
QUIT
WRITE !,LEX("HLP",X)
End DoDot:1
GOTO LEX
+22 ;display all codes and call reader
+23 SET APCDANS=""
+24 DO GETANS^APCDAPOV
+25 IF APCDY="^"
WRITE !
GOTO LEX
+26 IF APCDY=""
WRITE !
GOTO LEX
+27 IF '$GET(APCDY)
WRITE !
GOTO LEX
+28 IF APCDIMP=1
SET Y=$$ICDONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDDATE,"."))
+29 IF APCDIMP=30
SET Y=$$ONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$SELECT($PIECE(APCDDATE,".")>3141001:$PIECE(APCDDATE,"."),1:3141001),"10D")
+30 KILL DO,^TMP("LEXSCH",$JOB)
+31 IF $GET(Y)=""
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDTCLK=""
GOTO XITL
+32 SET %=$$ICDDX^ICDEX(Y,$PIECE(APCDDATE,"."),APCDIMP,"E")
+33 IF $PIECE(%,U,1)="-1"
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDTCLK=""
GOTO XITL
+34 SET APCDICD=$PIECE(%,U,1)
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 '$$CHKFH^AUPNSICD($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
+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)
+7 IF $PIECE(ALEXICD,"^",2)="INVALID CODE"
QUIT ""
+8 IF '$$CHKFH^AUPNSICD($PIECE(ALEXICD,U,1))
QUIT ""
+9 QUIT 1
