APCDFHD.m

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