APCLAUD5.m

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

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

 ;

 ;cmi/anch/maw 9/10/2007 code set versioning in DISPLAY

BEGIN ;

 W !

 S APCL("NO DISPLAY")=0

 D ASK1

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

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

X I $D(APCLTABL) D SETUTIL

 D EOJ

 Q

 ;

ASK1 ;

 ;WHAT CODING SYSTEM?

 S APCLSYS="",APCLA=0

 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 APCLSYS=+Y

 K APCL("LOW"),APCL("HI")

 S DIR("A")=$S('$D(APCLTABL):"Enter Diagnosis (or range of DX codes)",1:"Enter Another Diagnosis (or range of DX codes)") D SETDIR^APCLAUD6,^DIR K DIR

 I "^"[Y G X1

 D PROCESS

 I $D(APCLTABL),'APCL("NO DISPLAY") D RANGES

 S APCL("NO DISPLAY")=0

 G ASK1

X1 Q

 ;

PROCESS ;EVALUATE USER RESPONSE

 S (APCLSUB,APCLONE)=0 ;APCLSUB=0 => NO DELETE OF CODE(S),APCLONE=0 => RANGE OF CODES ENTERED

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

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

 I X'["-" S APCLTYP="LOW",APCLONE=1 D LOOK^APCLAUD6 G X2

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

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

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

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

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

 . S APCLSAVE("X")=X

 . I $L(X,"-")=3 S X=$P(APCLSAVE("X"),"-",2),APCLTYP="LOW" D LOOK^APCLAUD6 I 'APCLA S X=$P(APCLSAVE("X"),"-",3),APCLTYP="HI" W ! D LOOK^APCLAUD6 Q

 . I $L(APCLSAVE("X"),"-")=2 S X=$E(X,2,99),APCLTYP="LOW",APCLONE=1 D LOOK^APCLAUD6

 E  S APCLSAVE("X")=X S APCLTYP="LOW",X=$P(APCLSAVE("X"),"-") D LOOK^APCLAUD6 I 'APCLA S APCLTYP="HI",X=$P(APCLSAVE("X"),"-",2) W ! D LOOK^APCLAUD6

X2 Q

 ;

DISPLAY ;EP - SHOW CODES IN RANGE SELECTED

 W:$D(IOF) @IOF

 NEW APCLX,APCLQ,APCLARR,X

 ;W !!,"ICD codes in this range =>",!! W $P(APCL("LOW")," ") S APCLDFN=$O(^ICD9("BA",APCL("LOW"),"")) W ?9,$P(^ICD9(APCLDFN,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 APCLARR

 D LST^ATXAPI(APCLSYS,80,$$STRIP^XLFSTR(APCL("LOW"))_"-"_$$STRIP^XLFSTR(APCL("HI")),"CODE","APCLARR")

 S APCLX="",APCLQ=0 F  S APCLX=$O(APCLARR(APCLX)) Q:APCLX=""!($G(APCLQ))  D

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

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

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

 NEW DIR

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

 Q

EOP ;

 S APCLQ=0

 NEW DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

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

 I $D(DUOUT) S APCLQ=1 Q

 W:$D(IOF) @IOF

 Q

 ;

SETUTIL ;SET UP UTILITY NODES TO STORE CODES

 NEW APCLX,APCLQ,APCLARR

 S APCLIRNG=0,APCL("LOW")="" F  S APCL("LOW")=$O(APCLTABL(APCL("LOW"))) Q:APCL("LOW")=""  S APCL("HI")=$P(APCLTABL(APCL("LOW")),U,1) D

 .S APCLIRNG=APCLIRNG+1

 .KILL APCLX,APCLQ,APCLARR

 .D LST^ATXAPI(APCLSYS,80,$$STRIP^XLFSTR(APCL("LOW"))_"-"_$$STRIP^XLFSTR(APCL("HI")),"CODE","APCLARR")

 .S ^XTMP("APCLAUD",APCLJOB,APCLBT,APCLIRNG,"ICDB")=APCL("LOW")

 .S ^XTMP("APCLAUD",APCLJOB,APCLBT,APCLIRNG,"ICDE")=APCL("HI")

 .;S APCLDFN=$$CODEN^ICDEX(APCL("LOW")),^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",APCLDFN,APCLIRNG)=""

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

 ..S ^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",$P(APCLARR(X),U,1),APCLIRNG)=""

 .Q

 Q

RANGES ;DISPLAY TABLE OF ALL RANGES

 W:$D(IOF) @IOF

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

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

 I '$D(APCL("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 APCL("N"):300 W:"^"[APCL("N") ! Q:"^"[APCL("N")  I APCL("N")'?1N!(APCL("N")>APCL("NUM")) W "  ??",$C(7) G A

 F APCLI=1:1:APCL("N") S APCL=$O(APCLTABL(APCL)) I APCLI=APCL("N") S APCL("LOW")=APCL,APCL("HI")=$P(APCLTABL(APCL),U,1) D DISPLAY Q

 S APCL("BANG")="" D RANGES K APCL("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 ;ENTRY POINT

 I $D(APCL("NOT TAX")) K APCLSTP,APCLX

 K APCLSUB,APCLTYP,APCLDFN,DIR,APCLSAVE,APCLA,APCLCNT,APCL,APCLR,APCLI,APCLONE,APCLFLG

 Q

 ;

STAR ;

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

 NEW APCLTEMP

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

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

 S APCL("LOW")=$O(APCLTEMP(0))

 NEW Z,C

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

 S APCL("HI")=C

 D DISPLAY

 D ^APCLAUD7

 Q

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

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

 +2       ;

 +3       ;cmi/anch/maw 9/10/2007 code set versioning in DISPLAY

BEGIN     ;

 +1        WRITE !

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

 +3        DO ASK1

 +4        IF Y="^"

               SET APCLSTP=1

               GOTO X

 +5        IF $DATA(APCLTABL)

               DO CHECK

               IF Y'=1

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

X          IF $DATA(APCLTABL)

               DO SETUTIL

 +1        DO EOJ

 +2        QUIT 

 +3       ;

ASK1      ;

 +1       ;WHAT CODING SYSTEM?

 +2        SET APCLSYS=""

           SET APCLA=0

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

 +4        SET DIC="^ICDS("

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

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +5        IF Y=-1

               GOTO X1

 +6        SET APCLSYS=+Y

 +7        KILL APCL("LOW"),APCL("HI")

 +8        SET DIR("A")=$SELECT('$DATA(APCLTABL):"Enter Diagnosis (or range of DX codes)",1:"Enter Another Diagnosis (or range of DX codes)")

           DO SETDIR^APCLAUD6

           DO ^DIR

           KILL DIR

 +9        IF "^"[Y

               GOTO X1

 +10       DO PROCESS

 +11       IF $DATA(APCLTABL)

               IF 'APCL("NO DISPLAY")

                   DO RANGES

 +12       SET APCL("NO DISPLAY")=0

 +13       GOTO ASK1

X1         QUIT 

 +1       ;

PROCESS   ;EVALUATE USER RESPONSE

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

           SET (APCLSUB,APCLONE)=0

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

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

               SET APCL("NO DISPLAY")=1

               GOTO X2

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

               DO STAR

               GOTO X2

 +4        IF X'["-"

               SET APCLTYP="LOW"

               SET APCLONE=1

               DO LOOK^APCLAUD6

               GOTO X2

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

               IF '$DATA(APCLTABL)

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

                   GOTO X2

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

               WRITE $CHAR(7),"  ??"

               SET APCLA=1

               SET APCL("NO DISPLAY")=1

               GOTO X2

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

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

                   WRITE $CHAR(7),"  ??"

                   SET APCLA=1

                   SET APCL("NO DISPLAY")=1

                   GOTO X2

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

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

                   WRITE $CHAR(7),"  ??"

                   SET APCLA=1

                   SET APCL("NO DISPLAY")=1

                   GOTO X2

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

               SET APCLSUB=1

               Begin DoDot:1

 +10               SET APCLSAVE("X")=X

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

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

                       SET APCLTYP="LOW"

                       DO LOOK^APCLAUD6

                       IF 'APCLA

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

                           SET APCLTYP="HI"

                           WRITE !

                           DO LOOK^APCLAUD6

                           QUIT 

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

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

                       SET APCLTYP="LOW"

                       SET APCLONE=1

                       DO LOOK^APCLAUD6

               End DoDot:1

               IF 1

 +13      IF '$TEST

               SET APCLSAVE("X")=X

               SET APCLTYP="LOW"

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

               DO LOOK^APCLAUD6

               IF 'APCLA

                   SET APCLTYP="HI"

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

                   WRITE !

                   DO LOOK^APCLAUD6

X2         QUIT 

 +1       ;

DISPLAY   ;EP - SHOW CODES IN RANGE SELECTED

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        NEW APCLX,APCLQ,APCLARR,X

 +3       ;W !!,"ICD codes in this range =>",!! W $P(APCL("LOW")," ") S APCLDFN=$O(^ICD9("BA",APCL("LOW"),"")) W ?9,$P(^ICD9(APCLDFN,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 APCLARR

 +6        DO LST^ATXAPI(APCLSYS,80,$$STRIP^XLFSTR(APCL("LOW"))_"-"_$$STRIP^XLFSTR(APCL("HI")),"CODE","APCLARR")

 +7        SET APCLX=""

           SET APCLQ=0

           FOR 

               SET APCLX=$ORDER(APCLARR(APCLX))

               IF APCLX=""!($GET(APCLQ))

                   QUIT 

               Begin DoDot:1

 +8                IF $Y>(IOSL-2)

                       DO EOP

                       IF APCLQ

                           QUIT 

 +9                IF $PIECE(APCLARR(APCLX),U,2)=1

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

                       IF 1

 +10              IF '$TEST

                       WRITE !,APCLX,?12,$EXTRACT($PIECE($$ICDDX^ICDEX($PIECE(APCLARR(APCLX),U,1)),U,4),1,40),?60,$PIECE(APCLARR(APCLX),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 APCLQ=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 APCLQ=1

               QUIT 

 +6        IF $DATA(IOF)

               WRITE @IOF

 +7        QUIT 

 +8       ;

SETUTIL   ;SET UP UTILITY NODES TO STORE CODES

 +1        NEW APCLX,APCLQ,APCLARR

 +2        SET APCLIRNG=0

           SET APCL("LOW")=""

           FOR 

               SET APCL("LOW")=$ORDER(APCLTABL(APCL("LOW")))

               IF APCL("LOW")=""

                   QUIT 

               SET APCL("HI")=$PIECE(APCLTABL(APCL("LOW")),U,1)

               Begin DoDot:1

 +3                SET APCLIRNG=APCLIRNG+1

 +4                KILL APCLX,APCLQ,APCLARR

 +5                DO LST^ATXAPI(APCLSYS,80,$$STRIP^XLFSTR(APCL("LOW"))_"-"_$$STRIP^XLFSTR(APCL("HI")),"CODE","APCLARR")

 +6                SET ^XTMP("APCLAUD",APCLJOB,APCLBT,APCLIRNG,"ICDB")=APCL("LOW")

 +7                SET ^XTMP("APCLAUD",APCLJOB,APCLBT,APCLIRNG,"ICDE")=APCL("HI")

 +8       ;S APCLDFN=$$CODEN^ICDEX(APCL("LOW")),^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",APCLDFN,APCLIRNG)=""

 +9                SET X=""

                   FOR 

                       SET X=$ORDER(APCLARR(X))

                       IF X=""

                           QUIT 

                       Begin DoDot:2

 +10                       SET ^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",$PIECE(APCLARR(X),U,1),APCLIRNG)=""

                       End DoDot:2

 +11               QUIT 

               End DoDot:1

 +12       QUIT 

RANGES    ;DISPLAY TABLE OF ALL RANGES

 +1        IF $DATA(IOF)

               WRITE @IOF

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

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

           FOR 

               SET APCL=$ORDER(APCLTABL(APCL))

               IF APCL=""

                   QUIT 

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

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

 +4        IF '$DATA(APCL("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 APCL("N"):300

           IF "^"[APCL("N")

               WRITE !

           IF "^"[APCL("N")

               QUIT 

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

               WRITE "  ??",$CHAR(7)

               GOTO A

 +1        FOR APCLI=1:1:APCL("N")

               SET APCL=$ORDER(APCLTABL(APCL))

               IF APCLI=APCL("N")

                   SET APCL("LOW")=APCL

                   SET APCL("HI")=$PIECE(APCLTABL(APCL),U,1)

                   DO DISPLAY

                   QUIT 

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

           DO RANGES

           KILL APCL("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       ;ENTRY POINT

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

               KILL APCLSTP,APCLX

 +2        KILL APCLSUB,APCLTYP,APCLDFN,DIR,APCLSAVE,APCLA,APCLCNT,APCL,APCLR,APCLI,APCLONE,APCLFLG

 +3        QUIT 

 +4       ;

STAR      ;

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

               SET APCLSUB=1

 +2        NEW APCLTEMP

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

 +4        IF '$DATA(APCLTEMP)

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

               SET APCL("NO DISPLAY")=1

               QUIT 

 +5        SET APCL("LOW")=$ORDER(APCLTEMP(0))

 +6        NEW Z,C

 +7        SET (Z,C)=""

           FOR 

               SET Z=$ORDER(APCLTEMP(Z))

               IF Z=""

                   QUIT 

               SET C=Z

 +8        SET APCL("HI")=C

 +9        DO DISPLAY

 +10       DO ^APCLAUD7

 +11       QUIT