APCDETPD.m

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