ATXTAXI ; IHS/CMI/LAB - INTERFACE TO SELECT ICD CODES ;
;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
;
;
D INIT
BEGIN D ASK1
I Y="^" S ATXSTP=1 G X
I $D(ATXTBLE) D CHECK I Y'=1 G BEGIN ;@$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 ;
W !!,"Updating codes in the ",$P(^ATXAX(ATXTAXI,0),U)," Taxonomy.",!
S ATXA=0
K ATX("LOW"),ATX("HI")
S DIR("A")=$S('$D(ATXTBLE):"ENTER ICD PROCEDURE",1:"ENTER ANOTHER ICD PROCEDURE") D SETDIR,^DIR K DIR
I "^"[Y G X1
I Y="" G X1
D PROCESS
I $D(ATXTBLE),'ATX("NO DISPLAY") D RANGES
S ATX("NO DISPLAY")=0
G ASK1
X1 Q
;
ICDCS ;
NEW X,Y
;WHAT CODING SYSTEM?
S ATXSYS=""
W !,"You must enter the coding system from which you want to "_$S($G(ATXREMM):"remove ",1:" enter")_" a code,",!,"or range of codes.",!
S DIC="^ICDS(",DIC("S")="I $P(^(0),U,3)=80.1",DIC(0)="AEMQ" D ^DIC K DIC
I Y=-1 G X1
S ATXSYS=+Y
Q
STAR ;
I $E(X)="-" S ATXSUB=1
NEW ATXTEMP
D LST^ATXAPI(ATXSYS,80.1,$S($E(X)="-":$E(X,2,999),1:X),"CODE","ATXTEMP")
I '$D(ATXTEMP) W " ?? There are no codes in that range!" S ATX("NO DISPLAY")=1 Q
S ATX("LOW")=$O(ATXTEMP(0))
NEW Z,C
S (Z,C)="" F S Z=$O(ATXTEMP(Z)) Q:Z="" S C=Z
S ATX("HI")=C
D DISPLAY,^ATXTAXJ
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 $E(X,$L(X))="*" D ICDCS G:'$G(ATXSYS) X2 D STAR G X2
I X'["-" D ICDCS G:'$G(ATXSYS) X2 S ATXTYP="LOW",ATXONE=1 D LOOK 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
D ICDCS G:'$G(ATXSYS) 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 I 'ATXA S X=$P(ATXSAVE("X"),"-",3),ATXTYP="HI" W ! D LOOK Q
. I $L(ATXSAVE("X"),"-")=2 S X=$E(X,2,99),ATXTYP="LOW",ATXONE=1 D LOOK
E S ATXSAVE("X")=X S ATXTYP="LOW",X=$P(ATXSAVE("X"),"-") D LOOK I 'ATXA S ATXTYP="HI",X=$P(ATXSAVE("X"),"-",2) W ! D LOOK
X2 Q
;
DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
W:$D(IOF) @IOF
NEW ATXX,ATXQ,ATXARR
W !!,"ICD codes in this range =>",!!
;call new API to get all codes back in ATXARR
D LST^ATXAPI(ATXSYS,80.1,$$STRIP^XLFSTR(ATX("LOW"))_"-"_$$STRIP^XLFSTR(ATX("HI")),"CODE","ATXARR")
S ATXX="",ATXQ=0 F S ATXX=$O(ATXARR(ATXX)) Q:ATXX=""!($G(ATXQ)) D
.I $Y>(IOSL-2) D EOP Q:ATXQ
.I $P(ATXARR(ATXX),U,2)=2 W !,ATXX,?12,$E($P($$ICDOP^ICDEX($P(ATXARR(ATXX),U,1),,,"I"),U,5),1,40),?60,$P(ATXARR(ATXX),U,4) I 1
.E W !,ATXX,?12,$E($P($$ICDOP^ICDEX($P(ATXARR(ATXX),U,1),,,"I"),U,5),1,40),?60,$P(ATXARR(ATXX),U,4)
NEW DIR
S DIR(0)="E",DIR("A")="Press Enter to Continue <>" D ^DIR
Q
;
RANGES ;DISPLAY TABLE OF ALL RANGES
W:$D(IOF) @IOF
W !!,"ICD 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'=$P(ATXTBLE(ATX),U,1):"- "_$P(ATXTBLE(ATX),U,1),1:"") D
.I $P(ATXTBLE(ATX),U,2) W ?30,$P(^ICDS($P(ATXTBLE(ATX),U,2),0),U,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
D TAX^ATXCODE
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
;
LOOK ; ENTRY POINT - LOOKUP USER RESPONSE; SET UTILITY NODES
S DIC="^ICD0(",DIC(0)="EMF",ICDSYS=ATXSYS D ^DIC K DIC,DR
I Y<0 S ATXA=1 W $C(7)," ??" S ATX("NO DISPLAY")=1 G X4
S:ATXTYP="LOW" ATX("LOW")=$P($S(ATXSYS=2:$$ICDOP^ICDEX(+Y,,2,"I"),1:$$ICDOP^ICDEX(+Y,,31,"I")),U,2)_" "
I ATXTYP="LOW",ATXONE S ATX("HI")=ATX("LOW") D ^ATXTAXJ
I ATXTYP="HI" S ATX("HI")=$P($S(ATXSYS=2:$$ICDOP^ICDEX(+Y,,2,"I"),1:$$ICDOP^ICDEX(+Y,,31,"I")),U,2)_" " D I 'ATX("NO DISPLAY") D DISPLAY,^ATXTAXJ
. I $E(ATX("HI"))?1N&($E(ATX("LOW"))?1N)!($E(ATX("LOW"))'?1N&($E(ATX("HI"))'?1N))
. E W !,$C(7),"Low and high codes of range must both start either with a letter or a number.",! S ATX("NO DISPLAY")=1
. I 'ATX("NO DISPLAY") I ATX("LOW")]ATX("HI") W !,$C(7),"Low code is higher than high code.",! S ATX("NO DISPLAY")=1
X4 Q
;
SETDIR ; ENTRY POINT - SETS HELP AND DIR FOR INIT SUBROUTINE OF ATXCODE
S DIR(0)="FO",DIR("?",1)="Enter ICD Procedure code or narrative. You may enter a range of",DIR("?",2)="codes by placing a ""-"" between two codes. Codes in a range will"
S DIR("?",3)="include the first and last codes indicated and all codes that fall",DIR("?",4)="between. Only one code or one range of codes at a time. You may"
S DIR("?",5)="also enter ""[TAXONOMY NAME"" to select codes already within a taxonomy."
S DIR("?",6)="You can also ""de-select"" a code or range of codes by placing a ""-"" in",DIR("?",7)="front of it. (e.g. '-250.00' or '-250.01-250.91') Enter ""??"" to see"
S DIR("?")="code ranges selected so far."
S DIR("??")="^D ASK2^ATXTAXI"
Q
;
ASK2 ;ASKS USER IF WANTS TO DISPLAY/PRINT RESULTS TO THIS POINT
I '$D(ATXTBLE) W !!,"A code range has yet to be selected. A display cannot be generated.",! Q
W !!,"Do you want to display the codes from a range you have already selected" S %=1 D YN^DICN I %=1 D SHOW^ATXTAXI
I %=2!(%=-1) Q
I %=0 W !!,"A table of ranges you have selected is displayed above. You may ask for the",!,"codes in one of the ranges to be displayed.",! G ASK2
Q
;
EOP ;
S ATXQ=0
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR K DIR
I $D(DUOUT) S ATXQ=1 Q
W:$D(IOF) @IOF
Q
ATXTAXI ; IHS/CMI/LAB - INTERFACE TO SELECT ICD CODES ;
+1 ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
+2 ;
+3 ;
+4 DO INIT
BEGIN DO ASK1
+1 IF Y="^"
SET ATXSTP=1
GOTO X
+2 ;@$S(Y=0:"BEGIN",1:"X")
IF $DATA(ATXTBLE)
DO CHECK
IF Y'=1
GOTO BEGIN
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 WRITE !!,"Updating codes in the ",$PIECE(^ATXAX(ATXTAXI,0),U)," Taxonomy.",!
+2 SET ATXA=0
+3 KILL ATX("LOW"),ATX("HI")
+4 SET DIR("A")=$SELECT('$DATA(ATXTBLE):"ENTER ICD PROCEDURE",1:"ENTER ANOTHER ICD PROCEDURE")
DO SETDIR
DO ^DIR
KILL DIR
+5 IF "^"[Y
GOTO X1
+6 IF Y=""
GOTO X1
+7 DO PROCESS
+8 IF $DATA(ATXTBLE)
IF 'ATX("NO DISPLAY")
DO RANGES
+9 SET ATX("NO DISPLAY")=0
+10 GOTO ASK1
X1 QUIT
+1 ;
ICDCS ;
+1 NEW X,Y
+2 ;WHAT CODING SYSTEM?
+3 SET ATXSYS=""
+4 WRITE !,"You must enter the coding system from which you want to "_$SELECT($GET(ATXREMM):"remove ",1:" enter")_" a code,",!,"or range of codes.",!
+5 SET DIC="^ICDS("
SET DIC("S")="I $P(^(0),U,3)=80.1"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+6 IF Y=-1
GOTO X1
+7 SET ATXSYS=+Y
+8 QUIT
STAR ;
+1 IF $EXTRACT(X)="-"
SET ATXSUB=1
+2 NEW ATXTEMP
+3 DO LST^ATXAPI(ATXSYS,80.1,$SELECT($EXTRACT(X)="-":$EXTRACT(X,2,999),1:X),"CODE","ATXTEMP")
+4 IF '$DATA(ATXTEMP)
WRITE " ?? There are no codes in that range!"
SET ATX("NO DISPLAY")=1
QUIT
+5 SET ATX("LOW")=$ORDER(ATXTEMP(0))
+6 NEW Z,C
+7 SET (Z,C)=""
FOR
SET Z=$ORDER(ATXTEMP(Z))
IF Z=""
QUIT
SET C=Z
+8 SET ATX("HI")=C
+9 DO DISPLAY
DO ^ATXTAXJ
+10 QUIT
+11 ;
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 $EXTRACT(X,$LENGTH(X))="*"
DO ICDCS
IF '$GET(ATXSYS)
GOTO X2
DO STAR
GOTO X2
+5 IF X'["-"
DO ICDCS
IF '$GET(ATXSYS)
GOTO X2
SET ATXTYP="LOW"
SET ATXONE=1
DO LOOK
GOTO X2
+6 IF $EXTRACT(X)="-"
IF '$DATA(ATXTBLE)
WRITE $CHAR(7)," ?? No previous codes entered!"
GOTO X2
+7 IF $LENGTH(X,"-")>3
WRITE $CHAR(7)," ??"
SET ATXA=1
SET ATX("NO DISPLAY")=1
GOTO X2
+8 IF $LENGTH(X,"-")=3
IF $EXTRACT(X,$LENGTH(X))="-"
WRITE $CHAR(7)," ??"
SET ATXA=1
SET ATX("NO DISPLAY")=1
GOTO X2
+9 IF $LENGTH(X,"-")=3
IF $PIECE(X,"-")]""
WRITE $CHAR(7)," ??"
SET ATXA=1
SET ATX("NO DISPLAY")=1
GOTO X2
+10 DO ICDCS
IF '$GET(ATXSYS)
GOTO X2
+11 IF $EXTRACT(X)="-"
SET ATXSUB=1
Begin DoDot:1
+12 SET ATXSAVE("X")=X
+13 IF $LENGTH(X,"-")=3
SET X=$PIECE(ATXSAVE("X"),"-",2)
SET ATXTYP="LOW"
DO LOOK
IF 'ATXA
SET X=$PIECE(ATXSAVE("X"),"-",3)
SET ATXTYP="HI"
WRITE !
DO LOOK
QUIT
+14 IF $LENGTH(ATXSAVE("X"),"-")=2
SET X=$EXTRACT(X,2,99)
SET ATXTYP="LOW"
SET ATXONE=1
DO LOOK
End DoDot:1
IF 1
+15 IF '$TEST
SET ATXSAVE("X")=X
SET ATXTYP="LOW"
SET X=$PIECE(ATXSAVE("X"),"-")
DO LOOK
IF 'ATXA
SET ATXTYP="HI"
SET X=$PIECE(ATXSAVE("X"),"-",2)
WRITE !
DO LOOK
X2 QUIT
+1 ;
DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
+1 IF $DATA(IOF)
WRITE @IOF
+2 NEW ATXX,ATXQ,ATXARR
+3 WRITE !!,"ICD codes in this range =>",!!
+4 ;call new API to get all codes back in ATXARR
+5 DO LST^ATXAPI(ATXSYS,80.1,$$STRIP^XLFSTR(ATX("LOW"))_"-"_$$STRIP^XLFSTR(ATX("HI")),"CODE","ATXARR")
+6 SET ATXX=""
SET ATXQ=0
FOR
SET ATXX=$ORDER(ATXARR(ATXX))
IF ATXX=""!($GET(ATXQ))
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-2)
DO EOP
IF ATXQ
QUIT
+8 IF $PIECE(ATXARR(ATXX),U,2)=2
WRITE !,ATXX,?12,$EXTRACT($PIECE($$ICDOP^ICDEX($PIECE(ATXARR(ATXX),U,1),,,"I"),U,5),1,40),?60,$PIECE(ATXARR(ATXX),U,4)
IF 1
+9 IF '$TEST
WRITE !,ATXX,?12,$EXTRACT($PIECE($$ICDOP^ICDEX($PIECE(ATXARR(ATXX),U,1),,,"I"),U,5),1,40),?60,$PIECE(ATXARR(ATXX),U,4)
End DoDot:1
+10 NEW DIR
+11 SET DIR(0)="E"
SET DIR("A")="Press Enter to Continue <>"
DO ^DIR
+12 QUIT
+13 ;
RANGES ;DISPLAY TABLE OF ALL RANGES
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!,"ICD 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'=$PIECE(ATXTBLE(ATX),U,1):"- "_$PIECE(ATXTBLE(ATX),U,1),1:"")
Begin DoDot:1
+4 IF $PIECE(ATXTBLE(ATX),U,2)
WRITE ?30,$PIECE(^ICDS($PIECE(ATXTBLE(ATX),U,2),0),U,1)
End DoDot:1
+5 IF '$DATA(ATX("BANG"))
WRITE !
+6 QUIT
+7 ;
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 DO TAX^ATXCODE
+2 QUIT
+3 ;
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 ;
LOOK ; ENTRY POINT - LOOKUP USER RESPONSE; SET UTILITY NODES
+1 SET DIC="^ICD0("
SET DIC(0)="EMF"
SET ICDSYS=ATXSYS
DO ^DIC
KILL DIC,DR
+2 IF Y<0
SET ATXA=1
WRITE $CHAR(7)," ??"
SET ATX("NO DISPLAY")=1
GOTO X4
+3 IF ATXTYP="LOW"
SET ATX("LOW")=$PIECE($SELECT(ATXSYS=2:$$ICDOP^ICDEX(+Y,,2,"I"),1:$$ICDOP^ICDEX(+Y,,31,"I")),U,2)_" "
+4 IF ATXTYP="LOW"
IF ATXONE
SET ATX("HI")=ATX("LOW")
DO ^ATXTAXJ
+5 IF ATXTYP="HI"
SET ATX("HI")=$PIECE($SELECT(ATXSYS=2:$$ICDOP^ICDEX(+Y,,2,"I"),1:$$ICDOP^ICDEX(+Y,,31,"I")),U,2)_" "
Begin DoDot:1
+6 IF $EXTRACT(ATX("HI"))?1N&($EXTRACT(ATX("LOW"))?1N)!($EXTRACT(ATX("LOW"))'?1N&($EXTRACT(ATX("HI"))'?1N))
+7 IF '$TEST
WRITE !,$CHAR(7),"Low and high codes of range must both start either with a letter or a number.",!
SET ATX("NO DISPLAY")=1
+8 IF 'ATX("NO DISPLAY")
IF ATX("LOW")]ATX("HI")
WRITE !,$CHAR(7),"Low code is higher than high code.",!
SET ATX("NO DISPLAY")=1
End DoDot:1
IF 'ATX("NO DISPLAY")
DO DISPLAY
DO ^ATXTAXJ
X4 QUIT
+1 ;
SETDIR ; ENTRY POINT - SETS HELP AND DIR FOR INIT SUBROUTINE OF ATXCODE
+1 SET DIR(0)="FO"
SET DIR("?",1)="Enter ICD Procedure code or narrative. You may enter a range of"
SET DIR("?",2)="codes by placing a ""-"" between two codes. Codes in a range will"
+2 SET DIR("?",3)="include the first and last codes indicated and all codes that fall"
SET DIR("?",4)="between. Only one code or one range of codes at a time. You may"
+3 SET DIR("?",5)="also enter ""[TAXONOMY NAME"" to select codes already within a taxonomy."
+4 SET DIR("?",6)="You can also ""de-select"" a code or range of codes by placing a ""-"" in"
SET DIR("?",7)="front of it. (e.g. '-250.00' or '-250.01-250.91') Enter ""??"" to see"
+5 SET DIR("?")="code ranges selected so far."
+6 SET DIR("??")="^D ASK2^ATXTAXI"
+7 QUIT
+8 ;
ASK2 ;ASKS USER IF WANTS TO DISPLAY/PRINT RESULTS TO THIS POINT
+1 IF '$DATA(ATXTBLE)
WRITE !!,"A code range has yet to be selected. A display cannot be generated.",!
QUIT
+2 WRITE !!,"Do you want to display the codes from a range you have already selected"
SET %=1
DO YN^DICN
IF %=1
DO SHOW^ATXTAXI
+3 IF %=2!(%=-1)
QUIT
+4 IF %=0
WRITE !!,"A table of ranges you have selected is displayed above. You may ask for the",!,"codes in one of the ranges to be displayed.",!
GOTO ASK2
+5 QUIT
+6 ;
EOP ;
+1 SET ATXQ=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 ATXQ=1
QUIT
+6 IF $DATA(IOF)
WRITE @IOF
+7 QUIT
