APCDFQA3.m

APCDFQA3 ; IHS/CMI/LAB - USER INTERFACE TO SELECT ICD CODES ;

 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

BEGIN ;

 W !

 S APCD("NO DISPLAY")=0

 D ASK1

 I Y="^" S APCDSTP=1 G X

 I $D(APCDTABL) D CHECK I Y'=1 G @$S(Y=0:"BEGIN",1:"X")

X I $D(APCDTABL) D SETUTIL

 D EOJ

 Q

 ;

ASK1 ;

 S APCDA=0

 ;WHAT CODING SYSTEM?

 S APCDSYS=""

 W !,"You must enter the coding system from which you want to enter a code,",!,"or range of codes.",!

 S DIC="^ICDS(",DIC("S")="I $P(^(0),U,3)=80",DIC(0)="AEMQ" D ^DIC K DIC

 I Y=-1 G X1

 S APCDSYS=+Y

 K APCD("LOW"),APCD("HI")

 S DIR("A")=$S('$D(APCDTABL):"Enter Diagnosis (or range of DX codes)",1:"Enter another Diagnosis (or range of DX codes)") D SETDIR^APCDFQA4,^DIR K DIR

 I "^"[Y G X1

 D PROCESS

 I $D(APCDTABL),'APCD("NO DISPLAY") D RANGES

 S APCD("NO DISPLAY")=0

 G ASK1

X1 Q

 ;

PROCESS ;EVALUATE USER RESPONSE

 S (APCDSUB,APCDONE)=0 ;APCDSUB=0 => NO DELETE OF CODE(S),APCDONE=0 => RANGE OF CODES ENTERED

 I $E(X,1,2)="-[" W $C(7),"  ?? Not allowed" S APCD("NO DISPLAY")=1 G X2

 I $E(X,$L(X))="*" D STAR G X2

 I X'["-" S APCDTYP="LOW",APCDONE=1 D LOOK^APCDFQA4 G X2

 I $E(X)="-",'$D(APCDTABL) W $C(7),"  ??  No previous codes entered!" G X2

 I $L(X,"-")>3 W $C(7),"  ??"  S APCDA=1 S APCD("NO DISPLAY")=1 G X2

 I $L(X,"-")=3,$E(X,$L(X))="-" W $C(7),"  ??" S APCDA=1 S APCD("NO DISPLAY")=1 G X2

 I $L(X,"-")=3,$P(X,"-")]"" W $C(7),"  ??" S APCDA=1 S APCD("NO DISPLAY")=1 G X2

 I $E(X)="-" S APCDSUB=1 D  I 1

 . S APCDSAVE("X")=X

 . I $L(X,"-")=3 S X=$P(APCDSAVE("X"),"-",2),APCDTYP="LOW" D LOOK^APCDFQA4 I 'APCDA S X=$P(APCDSAVE("X"),"-",3),APCDTYP="HI" W ! D LOOK^APCDFQA4 Q

 . I $L(APCDSAVE("X"),"-")=2 S X=$E(X,2,99),APCDTYP="LOW",APCDONE=1 D LOOK^APCDFQA4

 E  S APCDSAVE("X")=X S APCDTYP="LOW",X=$P(APCDSAVE("X"),"-") D LOOK^APCDFQA4 I 'APCDA S APCDTYP="HI",X=$P(APCDSAVE("X"),"-",2) W ! D LOOK^APCDFQA4

X2 Q

 ;

DISPLAY ;EP - SHOW CODES IN RANGE SELECTED

 W:$D(IOF) @IOF

 NEW APCDX,APCDQ,APCDARR,X

 ;W !!,"ICD codes in this range =>",!! W $P(APCD("LOW")," ") S APCDDFN=$O(^ICD9("BA",APCD("LOW"),"")) W ?9,$P(^ICD9(APCDDFN,0),U,3)  ;cmi/anch/maw 9/10/2007 orig line

 W !!,"ICD codes in this range =>",!!

 ;call new API to get all codes back in APCDARR

 D LST^ATXAPI(APCDSYS,80,$$STRIP^XLFSTR(APCD("LOW"))_"-"_$$STRIP^XLFSTR(APCD("HI")),"CODE","APCDARR")

 S APCDX="",APCDQ=0 F  S APCDX=$O(APCDARR(APCDX)) Q:APCDX=""!($G(APCDQ))  D

 .I $Y>(IOSL-2) D EOP Q:APCDQ

 .I $P(APCDARR(APCDX),U,2)=1 W !,APCDX,?12,$E($P($$ICDDX^ICDEX($P(APCDARR(APCDX),U,1)),U,4),1,40),?60,$P(APCDARR(APCDX),U,4) I 1

 .E  W !,APCDX,?12,$E($P($$ICDDX^ICDEX($P(APCDARR(APCDX),U,1)),U,4),1,40),?60,$P(APCDARR(APCDX),U,4)

 NEW DIR

 S DIR(0)="E",DIR("A")="Press Enter to Continue <>" D ^DIR

 Q

EOP ;

 S APCDQ=0

 NEW DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 S DIR(0)="E" D ^DIR K DIR

 I $D(DUOUT) S APCDQ=1 Q

 W:$D(IOF) @IOF

 Q

STAR ;

 I $E(X)="-" S APCDSUB=1

 NEW APCDTEMP

 D LST^ATXAPI(APCDSYS,80,$S($E(X)="-":$E(X,2,999),1:X),"CODE","APCDTEMP")

 I '$D(APCDTEMP) W "  ?? There are no codes in that range!" S APCD("NO DISPLAY")=1 Q

 S APCD("LOW")=$O(APCDTEMP(0))

 NEW Z,C

 S (Z,C)="" F  S Z=$O(APCDTEMP(Z)) Q:Z=""  S C=Z

 S APCD("HI")=C

 D DISPLAY

 D ^APCDFQA5

 ;S APCDSAVE("X")=X S APCDTYP="LOW",X=APCD("LOW") D LOOK^APCDFQA4 I 'APCDA S APCDTYP="HI",X=APCD("HI") W ! D LOOK^APCDFQA4

 Q

 ;

SETUTIL ;SET UP TMP NODES TO STORE CODES

 NEW APCDX,APCDQ,APCDARR

 S APCDIRNG=0,APCD("LOW")="" F  S APCD("LOW")=$O(APCDTABL(APCD("LOW"))) Q:APCD("LOW")=""  S APCD("HI")=$P(APCDTABL(APCD("LOW")),U,1) D

 .S APCDIRNG=APCDIRNG+1

 .KILL APCDX,APCDQ,APCDARR

 .D LST^ATXAPI(APCDSYS,80,$$STRIP^XLFSTR(APCD("LOW"))_"-"_$$STRIP^XLFSTR(APCD("HI")),"CODE","APCDARR")

 .S ^XTMP("APCDFQA",APCDJOB,APCDBT,APCDIRNG,"ICDB")=APCD("LOW")

 .S ^XTMP("APCDFQA",APCDJOB,APCDBT,APCDIRNG,"ICDE")=APCD("HI")

 .S X="" F  S X=$O(APCDARR(X)) Q:X=""  D

 ..S ^XTMP("APCDFQA",APCDJOB,APCDBT,"DEPOV","ICDDFN",$P(APCDARR(X),U,1),APCDIRNG)=""

 .Q

 Q

RANGES ;DISPLAY TABLE OF ALL RANGES

 W:$D(IOF) @IOF

 W !!,"ICD Code Range(s) Selected So Far =>",!

 S (APCD("NUM"),APCD)=0 F  S APCD=$O(APCDTABL(APCD)) Q:APCD=""  S APCD("NUM")=APCD("NUM")+1 W !,APCD("NUM"),")  ",APCD,$S(APCD'=$P(APCDTABL(APCD),U,1):"- "_$P(APCDTABL(APCD),U,1),1:"")

 I '$D(APCD("BANG")) W !

 Q

 ;

SHOW ; ENTRY POINT - ALLOW USER TO SELECT FROM RANGES TO DISPLAY CODES

 D RANGES

A W !,"Enter an Item Number from the table above to display code(s): " R APCD("N"):300 W:"^"[APCD("N") ! Q:"^"[APCD("N")  I APCD("N")'?1N!(APCD("N")>APCD("NUM")) W "  ??",$C(7) G A

 F APCDI=1:1:APCD("N") S APCD=$O(APCDTABL(APCD)) I APCDI=APCD("N") S APCD("LOW")=APCD,APCD("HI")=$P(APCDTABL(APCD),U,1) D DISPLAY Q

 S APCD("BANG")="" D RANGES K APCD("BANG")

 Q

 ;

 ;

CHECK ;ASKS USER IF SATISFIED WITH ENTERED RANGES

 NEW DIR

 W ! S DIR(0)="Y",DIR("B")="Y",DIR("A")="Are all of the ICD ranges okay" D ^DIR K DIR

 W !

 Q

 ;

EOJ ;

 I $D(APCD("NOT TAX")) K APCDSTP,APCDX

 K APCDSUB,APCDTYP,APCDDFN,DIR,APCDSAVE,APCDA,APCDCNT,APCD,APCDR,APCDI,APCDONE,APCDFLG

 Q

 ;

APCDFQA3  ; IHS/CMI/LAB - USER INTERFACE TO SELECT ICD CODES ;

 +1       ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

BEGIN     ;

 +1        WRITE !

 +2        SET APCD("NO DISPLAY")=0

 +3        DO ASK1

 +4        IF Y="^"

               SET APCDSTP=1

               GOTO X

 +5        IF $DATA(APCDTABL)

               DO CHECK

               IF Y'=1

                   GOTO @$SELECT(Y=0:"BEGIN",1:"X")

X          IF $DATA(APCDTABL)

               DO SETUTIL

 +1        DO EOJ

 +2        QUIT 

 +3       ;

ASK1      ;

 +1        SET APCDA=0

 +2       ;WHAT CODING SYSTEM?

 +3        SET APCDSYS=""

 +4        WRITE !,"You must enter the coding system from which you want to enter a code,",!,"or range of codes.",!

 +5        SET DIC="^ICDS("

           SET DIC("S")="I $P(^(0),U,3)=80"

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +6        IF Y=-1

               GOTO X1

 +7        SET APCDSYS=+Y

 +8        KILL APCD("LOW"),APCD("HI")

 +9        SET DIR("A")=$SELECT('$DATA(APCDTABL):"Enter Diagnosis (or range of DX codes)",1:"Enter another Diagnosis (or range of DX codes)")

           DO SETDIR^APCDFQA4

           DO ^DIR

           KILL DIR

 +10       IF "^"[Y

               GOTO X1

 +11       DO PROCESS

 +12       IF $DATA(APCDTABL)

               IF 'APCD("NO DISPLAY")

                   DO RANGES

 +13       SET APCD("NO DISPLAY")=0

 +14       GOTO ASK1

X1         QUIT 

 +1       ;

PROCESS   ;EVALUATE USER RESPONSE

 +1       ;APCDSUB=0 => NO DELETE OF CODE(S),APCDONE=0 => RANGE OF CODES ENTERED

           SET (APCDSUB,APCDONE)=0

 +2        IF $EXTRACT(X,1,2)="-["

               WRITE $CHAR(7),"  ?? Not allowed"

               SET APCD("NO DISPLAY")=1

               GOTO X2

 +3        IF $EXTRACT(X,$LENGTH(X))="*"

               DO STAR

               GOTO X2

 +4        IF X'["-"

               SET APCDTYP="LOW"

               SET APCDONE=1

               DO LOOK^APCDFQA4

               GOTO X2

 +5        IF $EXTRACT(X)="-"

               IF '$DATA(APCDTABL)

                   WRITE $CHAR(7),"  ??  No previous codes entered!"

                   GOTO X2

 +6        IF $LENGTH(X,"-")>3

               WRITE $CHAR(7),"  ??"

               SET APCDA=1

               SET APCD("NO DISPLAY")=1

               GOTO X2

 +7        IF $LENGTH(X,"-")=3

               IF $EXTRACT(X,$LENGTH(X))="-"

                   WRITE $CHAR(7),"  ??"

                   SET APCDA=1

                   SET APCD("NO DISPLAY")=1

                   GOTO X2

 +8        IF $LENGTH(X,"-")=3

               IF $PIECE(X,"-")]""

                   WRITE $CHAR(7),"  ??"

                   SET APCDA=1

                   SET APCD("NO DISPLAY")=1

                   GOTO X2

 +9        IF $EXTRACT(X)="-"

               SET APCDSUB=1

               Begin DoDot:1

 +10               SET APCDSAVE("X")=X

 +11               IF $LENGTH(X,"-")=3

                       SET X=$PIECE(APCDSAVE("X"),"-",2)

                       SET APCDTYP="LOW"

                       DO LOOK^APCDFQA4

                       IF 'APCDA

                           SET X=$PIECE(APCDSAVE("X"),"-",3)

                           SET APCDTYP="HI"

                           WRITE !

                           DO LOOK^APCDFQA4

                           QUIT 

 +12               IF $LENGTH(APCDSAVE("X"),"-")=2

                       SET X=$EXTRACT(X,2,99)

                       SET APCDTYP="LOW"

                       SET APCDONE=1

                       DO LOOK^APCDFQA4

               End DoDot:1

               IF 1

 +13      IF '$TEST

               SET APCDSAVE("X")=X

               SET APCDTYP="LOW"

               SET X=$PIECE(APCDSAVE("X"),"-")

               DO LOOK^APCDFQA4

               IF 'APCDA

                   SET APCDTYP="HI"

                   SET X=$PIECE(APCDSAVE("X"),"-",2)

                   WRITE !

                   DO LOOK^APCDFQA4

X2         QUIT 

 +1       ;

DISPLAY   ;EP - SHOW CODES IN RANGE SELECTED

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        NEW APCDX,APCDQ,APCDARR,X

 +3       ;W !!,"ICD codes in this range =>",!! W $P(APCD("LOW")," ") S APCDDFN=$O(^ICD9("BA",APCD("LOW"),"")) W ?9,$P(^ICD9(APCDDFN,0),U,3)  ;cmi/anch/maw 9/10/2007 orig line

 +4        WRITE !!,"ICD codes in this range =>",!!

 +5       ;call new API to get all codes back in APCDARR

 +6        DO LST^ATXAPI(APCDSYS,80,$$STRIP^XLFSTR(APCD("LOW"))_"-"_$$STRIP^XLFSTR(APCD("HI")),"CODE","APCDARR")

 +7        SET APCDX=""

           SET APCDQ=0

           FOR 

               SET APCDX=$ORDER(APCDARR(APCDX))

               IF APCDX=""!($GET(APCDQ))

                   QUIT 

               Begin DoDot:1

 +8                IF $Y>(IOSL-2)

                       DO EOP

                       IF APCDQ

                           QUIT 

 +9                IF $PIECE(APCDARR(APCDX),U,2)=1

                       WRITE !,APCDX,?12,$EXTRACT($PIECE($$ICDDX^ICDEX($PIECE(APCDARR(APCDX),U,1)),U,4),1,40),?60,$PIECE(APCDARR(APCDX),U,4)

                       IF 1

 +10              IF '$TEST

                       WRITE !,APCDX,?12,$EXTRACT($PIECE($$ICDDX^ICDEX($PIECE(APCDARR(APCDX),U,1)),U,4),1,40),?60,$PIECE(APCDARR(APCDX),U,4)

               End DoDot:1

 +11       NEW DIR

 +12       SET DIR(0)="E"

           SET DIR("A")="Press Enter to Continue <>"

           DO ^DIR

 +13       QUIT 

EOP       ;

 +1        SET APCDQ=0

 +2        NEW DIR

 +3        KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 +4        SET DIR(0)="E"

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DUOUT)

               SET APCDQ=1

               QUIT 

 +6        IF $DATA(IOF)

               WRITE @IOF

 +7        QUIT 

STAR      ;

 +1        IF $EXTRACT(X)="-"

               SET APCDSUB=1

 +2        NEW APCDTEMP

 +3        DO LST^ATXAPI(APCDSYS,80,$SELECT($EXTRACT(X)="-":$EXTRACT(X,2,999),1:X),"CODE","APCDTEMP")

 +4        IF '$DATA(APCDTEMP)

               WRITE "  ?? There are no codes in that range!"

               SET APCD("NO DISPLAY")=1

               QUIT 

 +5        SET APCD("LOW")=$ORDER(APCDTEMP(0))

 +6        NEW Z,C

 +7        SET (Z,C)=""

           FOR 

               SET Z=$ORDER(APCDTEMP(Z))

               IF Z=""

                   QUIT 

               SET C=Z

 +8        SET APCD("HI")=C

 +9        DO DISPLAY

 +10       DO ^APCDFQA5

 +11      ;S APCDSAVE("X")=X S APCDTYP="LOW",X=APCD("LOW") D LOOK^APCDFQA4 I 'APCDA S APCDTYP="HI",X=APCD("HI") W ! D LOOK^APCDFQA4

 +12       QUIT 

 +13      ;

SETUTIL   ;SET UP TMP NODES TO STORE CODES

 +1        NEW APCDX,APCDQ,APCDARR

 +2        SET APCDIRNG=0

           SET APCD("LOW")=""

           FOR 

               SET APCD("LOW")=$ORDER(APCDTABL(APCD("LOW")))

               IF APCD("LOW")=""

                   QUIT 

               SET APCD("HI")=$PIECE(APCDTABL(APCD("LOW")),U,1)

               Begin DoDot:1

 +3                SET APCDIRNG=APCDIRNG+1

 +4                KILL APCDX,APCDQ,APCDARR

 +5                DO LST^ATXAPI(APCDSYS,80,$$STRIP^XLFSTR(APCD("LOW"))_"-"_$$STRIP^XLFSTR(APCD("HI")),"CODE","APCDARR")

 +6                SET ^XTMP("APCDFQA",APCDJOB,APCDBT,APCDIRNG,"ICDB")=APCD("LOW")

 +7                SET ^XTMP("APCDFQA",APCDJOB,APCDBT,APCDIRNG,"ICDE")=APCD("HI")

 +8                SET X=""

                   FOR 

                       SET X=$ORDER(APCDARR(X))

                       IF X=""

                           QUIT 

                       Begin DoDot:2

 +9                        SET ^XTMP("APCDFQA",APCDJOB,APCDBT,"DEPOV","ICDDFN",$PIECE(APCDARR(X),U,1),APCDIRNG)=""

                       End DoDot:2

 +10               QUIT 

               End DoDot:1

 +11       QUIT 

RANGES    ;DISPLAY TABLE OF ALL RANGES

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !!,"ICD Code Range(s) Selected So Far =>",!

 +3        SET (APCD("NUM"),APCD)=0

           FOR 

               SET APCD=$ORDER(APCDTABL(APCD))

               IF APCD=""

                   QUIT 

               SET APCD("NUM")=APCD("NUM")+1

               WRITE !,APCD("NUM"),")  ",APCD,$SELECT(APCD'=$PIECE(APCDTABL(APCD),U,1):"- "_$PIECE(APCDTABL(APCD),U,1),1:"")

 +4        IF '$DATA(APCD("BANG"))

               WRITE !

 +5        QUIT 

 +6       ;

SHOW      ; ENTRY POINT - ALLOW USER TO SELECT FROM RANGES TO DISPLAY CODES

 +1        DO RANGES

A          WRITE !,"Enter an Item Number from the table above to display code(s): "

           READ APCD("N"):300

           IF "^"[APCD("N")

               WRITE !

           IF "^"[APCD("N")

               QUIT 

           IF APCD("N")'?1N!(APCD("N")>APCD("NUM"))

               WRITE "  ??",$CHAR(7)

               GOTO A

 +1        FOR APCDI=1:1:APCD("N")

               SET APCD=$ORDER(APCDTABL(APCD))

               IF APCDI=APCD("N")

                   SET APCD("LOW")=APCD

                   SET APCD("HI")=$PIECE(APCDTABL(APCD),U,1)

                   DO DISPLAY

                   QUIT 

 +2        SET APCD("BANG")=""

           DO RANGES

           KILL APCD("BANG")

 +3        QUIT 

 +4       ;

 +5       ;

CHECK     ;ASKS USER IF SATISFIED WITH ENTERED RANGES

 +1        NEW DIR

 +2        WRITE !

           SET DIR(0)="Y"

           SET DIR("B")="Y"

           SET DIR("A")="Are all of the ICD ranges okay"

           DO ^DIR

           KILL DIR

 +3        WRITE !

 +4        QUIT 

 +5       ;

EOJ       ;

 +1        IF $DATA(APCD("NOT TAX"))

               KILL APCDSTP,APCDX

 +2        KILL APCDSUB,APCDTYP,APCDDFN,DIR,APCDSAVE,APCDA,APCDCNT,APCD,APCDR,APCDI,APCDONE,APCDFLG

 +3        QUIT 

 +4       ;