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 ;
