ATXTAXM.m

ATXTAXM ; IHS/CMI/LAB - INTERFACE TO SELECT ICD CODES ;

 ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48

 ;

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

 ;

 D INIT

BEGIN D ASK1

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

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

X D EOJ

 Q

 ;

INIT ;

 S ATX("NO DISPLAY")=0

 I $D(ATXX) D  I 1

 . I $D(ATXTBLE) S ATX("MODIFY")=1 D RANGES I 1

 . E  S ATX("ENTER")=1

 E  S ATX("NOT TAX")=""

 Q

 ;

ASK1 ;

 S ATXA=0

 K ATX("LOW"),ATX("HI")

 S DIR("A")=$S('$D(ATXTBLE):"ENTER CPT",1:"ENTER ANOTHER CPT") D SETDIR^ATXTAXO,^DIR K DIR

 I "^"[Y G X1

 D PROCESS

 I $D(ATXTBLE),'ATX("NO DISPLAY") D RANGES

 S ATX("NO DISPLAY")=0

 G ASK1

X1 Q

 ;

PROCESS ;EVALUATE USER RESPONSE

 S (ATXSUB,ATXONE)=0 ;ATXSUB=0 => NO DELETE OF CODE(S),ATXONE=0 => RANGE OF CODES ENTERED

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

 I $E(X)="[" D TAX G X2

 I X'["-" S ATXTYP="LOW",ATXONE=1 D LOOK^ATXTAXO G X2

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

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

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

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

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

 . S ATXSAVE("X")=X

 . I $L(X,"-")=3 S X=$P(ATXSAVE("X"),"-",2),ATXTYP="LOW" D LOOK^ATXTAXO I 'ATXA S X=$P(ATXSAVE("X"),"-",3),ATXTYP="HI" W ! D LOOK^ATXTAXO Q

 . I $L(ATXSAVE("X"),"-")=2 S X=$E(X,2,99),ATXTYP="LOW",ATXONE=1 D LOOK^ATXTAXO

 E  S ATXSAVE("X")=X S ATXTYP="LOW",X=$P(ATXSAVE("X"),"-") D LOOK^ATXTAXO I 'ATXA S ATXTYP="HI",X=$P(ATXSAVE("X"),"-",2) W ! D LOOK^ATXTAXO

X2 Q

 ;

DISPLAY ;EP - SHOW CODES IN RANGE SELECTED

 W:$D(IOF) @IOF

 ;W !!,"CPT codes in this range =>",!! W $P(ATX("LOW")," ") S ATXDFN=$O(^ICPT("BA",ATX("LOW"),"")) W ?9,$P(^ICPT(ATXDFN,0),U,2)  ;cmi/anch/maw 9/12/2007 orig line

 W !!,"CPT codes in this range =>",!! W $P(ATX("LOW")," ") S ATXDFN=$O(^ICPT("BA",ATX("LOW"),"")) W ?9,$P($$CPT^ICPTCOD(ATXDFN),U,3)  ;cmi/anch/maw 9/12/2007 csv

 ;S ATX=ATX("LOW"),ATXCNT=IOSL-2 F  S ATX=$O(^ICPT("BA",ATX)) Q:ATX]ATX("HI")  S ATXDFN=$O(^(ATX,"")) W !,$P(ATX," "),?9,$P(^ICPT(ATXDFN,0),U,2) S ATXCNT=ATXCNT-1 I ATXCNT=0 S ATXCNT=IOSL-2 D  I ATXR=U Q  ;cmi/maw orig line

 S ATX=ATX("LOW"),ATXCNT=IOSL-2 F  S ATX=$O(^ICPT("BA",ATX)) Q:ATX]ATX("HI")  S ATXDFN=$O(^(ATX,"")) W !,$P(ATX," "),?9,$P($$CPT^ICPTCOD(ATXDFN),U,3) S ATXCNT=ATXCNT-1 I ATXCNT=0 S ATXCNT=IOSL-2 D  I ATXR=U Q  ;cmi/maw csv

A1 . R !,"<>",ATXR:DTIME W:ATXR["?" " Enter ""^"" to stop display, return to continue" G:ATXR["?" A1

 I $S('$D(ATXR):1,ATXR'=U:1,1:0) R !!,"Press return to continue",ATXR:DTIME

 W !

 K ATXR Q

 ;

RANGES ;DISPLAY TABLE OF ALL RANGES

 W:$D(IOF) @IOF

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

 S (ATX("NUM"),ATX)=0 F  S ATX=$O(ATXTBLE(ATX)) Q:ATX=""  S ATX("NUM")=ATX("NUM")+1 W !,ATX("NUM"),")  ",ATX,$S(ATX'=ATXTBLE(ATX):"- "_ATXTBLE(ATX),1:"")

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

 F ATXI=1:1:ATX("N") S ATX=$O(ATXTBLE(ATX)) I ATXI=ATX("N") S ATX("LOW")=ATX,ATX("HI")=ATXTBLE(ATX) D DISPLAY Q

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

 Q

 ;

TAX ;PLACE CODES FROM SELECTED TAXONOMY IN ATXTBLE

 S ATX("S")="I Y'=ATXX",ATX("S")=$S($D(ATXX):ATX("S")_",$O(^ATXAX(Y,21,0))",1:"I $O(^(21,0))"),DIC("A")="TAXONOMY FROM WHICH TO SELECT CODES: ",ATX("S")=ATX("S")_$S('$D(ATXX):"",1:",$P(^ATXAX(ATXX,0),U,15)=$P(^ATXAX(Y,0),U,15)")

 I $E(X,2)="?" S X="?",DIC="^ATXAX(",DIC(0)="EM",DIC("S")=ATX("S") D ^DIC S DIC(0)="AEMQ",DIC("S")=ATX("S"),DIC="^ATXAX(" D ^DIC K DIC I 1

 E  S X=$E(X,2,99),DIC(0)="EMQ",DIC("S")=ATX("S"),DIC="^ATXAX(" D ^DIC K DIC

 I Y=-1 G X3

 S ATX("CODE")=0 F  S ATX("CODE")=$O(^ATXAX(+Y,21,"AA",ATX("CODE"))) Q:ATX("CODE")=""  S ATXTBLE(ATX("CODE"))=$O(^(ATX("CODE"),""))

X3 W ! Q

 ;

CHECK ;ASKS USER IF SATISFIED WITH ENTERED RANGES

 W ! S DIR(0)="Y",DIR("B")="Y",DIR("A")="Is everything okay" D ^DIR K DIR

 W !

 Q

 ;

EOJ ;

 K ATXSUB,ATXTYP,ATXDFN,DIR,ATXSAVE,ATXA,ATXCNT,ATX,ATXR,ATXI,ATXONE,ATXFLG,ATXSTP

 Q

 ;

ATXTAXM   ; IHS/CMI/LAB - INTERFACE TO SELECT ICD CODES ;

 +1       ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48

 +2       ;

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

 +4       ;

 +5        DO INIT

BEGIN      DO ASK1

 +1        IF Y="^"

               SET ATXSTP=1

               GOTO X

 +2        IF $DATA(ATXTBLE)

               DO CHECK

               IF Y'=1

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

X          DO EOJ

 +1        QUIT 

 +2       ;

INIT      ;

 +1        SET ATX("NO DISPLAY")=0

 +2        IF $DATA(ATXX)

               Begin DoDot:1

 +3                IF $DATA(ATXTBLE)

                       SET ATX("MODIFY")=1

                       DO RANGES

                       IF 1

 +4               IF '$TEST

                       SET ATX("ENTER")=1

               End DoDot:1

               IF 1

 +5       IF '$TEST

               SET ATX("NOT TAX")=""

 +6        QUIT 

 +7       ;

ASK1      ;

 +1        SET ATXA=0

 +2        KILL ATX("LOW"),ATX("HI")

 +3        SET DIR("A")=$SELECT('$DATA(ATXTBLE):"ENTER CPT",1:"ENTER ANOTHER CPT")

           DO SETDIR^ATXTAXO

           DO ^DIR

           KILL DIR

 +4        IF "^"[Y

               GOTO X1

 +5        DO PROCESS

 +6        IF $DATA(ATXTBLE)

               IF 'ATX("NO DISPLAY")

                   DO RANGES

 +7        SET ATX("NO DISPLAY")=0

 +8        GOTO ASK1

X1         QUIT 

 +1       ;

PROCESS   ;EVALUATE USER RESPONSE

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

           SET (ATXSUB,ATXONE)=0

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

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

               SET ATX("NO DISPLAY")=1

               GOTO X2

 +3        IF $EXTRACT(X)="["

               DO TAX

               GOTO X2

 +4        IF X'["-"

               SET ATXTYP="LOW"

               SET ATXONE=1

               DO LOOK^ATXTAXO

               GOTO X2

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

               IF '$DATA(ATXTBLE)

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

                   GOTO X2

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

               WRITE $CHAR(7),"  ??"

               SET ATXA=1

               SET ATX("NO DISPLAY")=1

               GOTO X2

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

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

                   WRITE $CHAR(7),"  ??"

                   SET ATXA=1

                   SET ATX("NO DISPLAY")=1

                   GOTO X2

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

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

                   WRITE $CHAR(7),"  ??"

                   SET ATXA=1

                   SET ATX("NO DISPLAY")=1

                   GOTO X2

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

               SET ATXSUB=1

               Begin DoDot:1

 +10               SET ATXSAVE("X")=X

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

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

                       SET ATXTYP="LOW"

                       DO LOOK^ATXTAXO

                       IF 'ATXA

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

                           SET ATXTYP="HI"

                           WRITE !

                           DO LOOK^ATXTAXO

                           QUIT 

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

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

                       SET ATXTYP="LOW"

                       SET ATXONE=1

                       DO LOOK^ATXTAXO

               End DoDot:1

               IF 1

 +13      IF '$TEST

               SET ATXSAVE("X")=X

               SET ATXTYP="LOW"

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

               DO LOOK^ATXTAXO

               IF 'ATXA

                   SET ATXTYP="HI"

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

                   WRITE !

                   DO LOOK^ATXTAXO

X2         QUIT 

 +1       ;

DISPLAY   ;EP - SHOW CODES IN RANGE SELECTED

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2       ;W !!,"CPT codes in this range =>",!! W $P(ATX("LOW")," ") S ATXDFN=$O(^ICPT("BA",ATX("LOW"),"")) W ?9,$P(^ICPT(ATXDFN,0),U,2)  ;cmi/anch/maw 9/12/2007 orig line

 +3       ;cmi/anch/maw 9/12/2007 csv

           WRITE !!,"CPT codes in this range =>",!!

           WRITE $PIECE(ATX("LOW")," ")

           SET ATXDFN=$ORDER(^ICPT("BA",ATX("LOW"),""))

           WRITE ?9,$PIECE($$CPT^ICPTCOD(ATXDFN),U,3)

 +4       ;S ATX=ATX("LOW"),ATXCNT=IOSL-2 F  S ATX=$O(^ICPT("BA",ATX)) Q:ATX]ATX("HI")  S ATXDFN=$O(^(ATX,"")) W !,$P(ATX," "),?9,$P(^ICPT(ATXDFN,0),U,2) S ATXCNT=ATXCNT-1 I ATXCNT=0 S ATXCNT=IOSL-2 D  I ATXR=U Q  ;cmi/maw orig line

 +5       ;cmi/maw csv

           SET ATX=ATX("LOW")

           SET ATXCNT=IOSL-2

           FOR 

               SET ATX=$ORDER(^ICPT("BA",ATX))

               IF ATX]ATX("HI")

                   QUIT 

               SET ATXDFN=$ORDER(^(ATX,""))

               WRITE !,$PIECE(ATX," "),?9,$PIECE($$CPT^ICPTCOD(ATXDFN),U,3)

               SET ATXCNT=ATXCNT-1

               IF ATXCNT=0

                   SET ATXCNT=IOSL-2

                   Begin DoDot:1

A1                     READ !,"<>",ATXR:DTIME

                       IF ATXR["?"

                           WRITE " Enter ""^"" to stop display, return to continue"

                       IF ATXR["?"

                           GOTO A1

                   End DoDot:1

                   IF ATXR=U

                       QUIT 

 +1        IF $SELECT('$DATA(ATXR):1,ATXR'=U:1,1:0)

               READ !!,"Press return to continue",ATXR:DTIME

 +2        WRITE !

 +3        KILL ATXR

           QUIT 

 +4       ;

RANGES    ;DISPLAY TABLE OF ALL RANGES

 +1        IF $DATA(IOF)

               WRITE @IOF

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

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

           FOR 

               SET ATX=$ORDER(ATXTBLE(ATX))

               IF ATX=""

                   QUIT 

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

               WRITE !,ATX("NUM"),")  ",ATX,$SELECT(ATX'=ATXTBLE(ATX):"- "_ATXTBLE(ATX),1:"")

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

           IF "^"[ATX("N")

               WRITE !

           IF "^"[ATX("N")

               QUIT 

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

               WRITE "  ??",$CHAR(7)

               GOTO A

 +1        FOR ATXI=1:1:ATX("N")

               SET ATX=$ORDER(ATXTBLE(ATX))

               IF ATXI=ATX("N")

                   SET ATX("LOW")=ATX

                   SET ATX("HI")=ATXTBLE(ATX)

                   DO DISPLAY

                   QUIT 

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

           DO RANGES

           KILL ATX("BANG")

 +3        QUIT 

 +4       ;

TAX       ;PLACE CODES FROM SELECTED TAXONOMY IN ATXTBLE

 +1        SET ATX("S")="I Y'=ATXX"

           SET ATX("S")=$SELECT($DATA(ATXX):ATX("S")_",$O(^ATXAX(Y,21,0))",1:"I $O(^(21,0))")

           SET DIC("A")="TAXONOMY FROM WHICH TO SELECT CODES: "

           SET ATX("S")=ATX("S")_$SELECT('$DATA(ATXX):"",1:",$P(^ATXAX(ATXX,0),U,15)=$P(^ATXAX(Y,0),U,15)")

 +2        IF $EXTRACT(X,2)="?"

               SET X="?"

               SET DIC="^ATXAX("

               SET DIC(0)="EM"

               SET DIC("S")=ATX("S")

               DO ^DIC

               SET DIC(0)="AEMQ"

               SET DIC("S")=ATX("S")

               SET DIC="^ATXAX("

               DO ^DIC

               KILL DIC

               IF 1

 +3       IF '$TEST

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

               SET DIC(0)="EMQ"

               SET DIC("S")=ATX("S")

               SET DIC="^ATXAX("

               DO ^DIC

               KILL DIC

 +4        IF Y=-1

               GOTO X3

 +5        SET ATX("CODE")=0

           FOR 

               SET ATX("CODE")=$ORDER(^ATXAX(+Y,21,"AA",ATX("CODE")))

               IF ATX("CODE")=""

                   QUIT 

               SET ATXTBLE(ATX("CODE"))=$ORDER(^(ATX("CODE"),""))

X3         WRITE !

           QUIT 

 +1       ;

CHECK     ;ASKS USER IF SATISFIED WITH ENTERED RANGES

 +1        WRITE !

           SET DIR(0)="Y"

           SET DIR("B")="Y"

           SET DIR("A")="Is everything okay"

           DO ^DIR

           KILL DIR

 +2        WRITE !

 +3        QUIT 

 +4       ;

EOJ       ;

 +1        KILL ATXSUB,ATXTYP,ATXDFN,DIR,ATXSAVE,ATXA,ATXCNT,ATX,ATXR,ATXI,ATXONE,ATXFLG,ATXSTP

 +2        QUIT 

 +3       ;