- ATXCODE ; IHS/CMI/LAB - INTERFACE TO SELECT ICD CODES ;
- ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
- ;
- ;cmi/anch/maw 9/10/2007 code set versioning in DISPLAY
- ;
- I ATXFILE=80.1 G ^ATXTAXI
- 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
- I $G(ATXREMM) W !!,"To remove a code from the list, enter an ""-"" before the code, e.g. -250.00 or -250.00-250.93",!
- K ATX("LOW"),ATX("HI")
- S DIR("A")=$S('$D(ATXTBLE):"ENTER DX",1:"ENTER ANOTHER DX") 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 ;
- ;WHAT CODING SYSTEM?
- S ATXSYS=""
- NEW Y,X
- 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",DIC(0)="AEMQ" D ^DIC K DIC
- I Y=-1 G X1
- S ATXSYS=+Y
- Q
- ;I Y="*" W !!,"Sorry, '*' is not allowed.
- ;
- LOOK ; ENTRY POINT - LOOKUP USER RESPONSE; SET UTILITY NODES
- S DIC="^ICD9(",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 X3
- S:ATXTYP="LOW" ATX("LOW")=$P($S(ATXSYS=1:$$ICDDX^ICDEX(+Y),1:$$ICDDX^ICDEX(+Y)),U,2)_" "
- I ATXTYP="LOW",ATXONE S ATX("HI")=ATX("LOW") D ^ATXCOD1
- I ATXTYP="HI" S ATX("HI")=$P($S(ATXSYS=1:$$ICDDX^ICDEX(+Y),1:$$ICDDX^ICDEX(+Y)),U,2)_" " D I 'ATX("NO DISPLAY") D DISPLAY,^ATXCOD1
- . 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
- X3 Q
- ;
- SETDIR ; ENTRY POINT - SETS HELP AND DIR FOR INIT SUBROUTINE OF ATXCODE
- S DIR(0)="FO",DIR("?",1)="Enter ICD diagnosis 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)="To select all codes in a set you can use a '*' wildcard. E.g. E11*, 250*"
- S DIR("?",7)="You can also ""de-select"" a code or range of codes by placing a ""-"" in",DIR("?",8)="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^ATXCODE"
- 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^ATXCODE
- 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
- ;
- STAR ;
- I $E(X)="-" S ATXSUB=1
- NEW ATXTEMP
- D LST^ATXAPI(ATXSYS,80,$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,^ATXCOD1
- 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 " ?? 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
- ;
- 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
- DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
- W:$D(IOF) @IOF
- NEW ATXX,ATXQ,ATXARR
- ;W !!,"ICD codes in this range =>",!! W $P(ATX("LOW")," ") S ATXDFN=$O(^ICD9("BA",ATX("LOW"),"")) W ?9,$P(^ICD9(ATXDFN,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 ATXARR
- D LST^ATXAPI(ATXSYS,80,$$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)=1 W !,ATXX,?12,$E($P($$ICDDX^ICDEX($P(ATXARR(ATXX),U,1)),U,4),1,40),?60,$P(ATXARR(ATXX),U,4) I 1
- .E W !,ATXX,?12,$E($P($$ICDDX^ICDEX($P(ATXARR(ATXX),U,1)),U,4),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 ;EP - 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 X4
- ;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"),""))
- NEW X,A,B,ATXN
- S ATXN=+Y
- S X="" F S X=$O(^ATXAX(ATXN,21,"B",X)) Q:X="" D
- .S Y=0 F S Y=$O(^ATXAX(ATXN,21,"B",X,Y)) Q:Y="" D
- ..S A=$P(^ATXAX(ATXN,21,Y,0),U,1),B=$P(^ATXAX(ATXN,21,Y,0),U,2),C=$P(^ATXAX(ATXN,21,Y,0),U,3)
- ..S ATXTBLE(A)=B_U_C
- X4 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
- ;
- ATXCODE ; IHS/CMI/LAB - INTERFACE TO SELECT ICD CODES ;
- +1 ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
- +2 ;
- +3 ;cmi/anch/maw 9/10/2007 code set versioning in DISPLAY
- +4 ;
- +5 IF ATXFILE=80.1
- GOTO ^ATXTAXI
- +6 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 IF $GET(ATXREMM)
- WRITE !!,"To remove a code from the list, enter an ""-"" before the code, e.g. -250.00 or -250.00-250.93",!
- +4 KILL ATX("LOW"),ATX("HI")
- +5 SET DIR("A")=$SELECT('$DATA(ATXTBLE):"ENTER DX",1:"ENTER ANOTHER DX")
- DO SETDIR
- DO ^DIR
- KILL DIR
- +6 IF "^"[Y
- GOTO X1
- +7 IF Y=""
- GOTO X1
- +8 DO PROCESS
- +9 IF $DATA(ATXTBLE)
- IF 'ATX("NO DISPLAY")
- DO RANGES
- +10 SET ATX("NO DISPLAY")=0
- +11 GOTO ASK1
- X1 QUIT
- ICDCS ;
- +1 ;WHAT CODING SYSTEM?
- +2 SET ATXSYS=""
- +3 NEW Y,X
- +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"
- SET DIC(0)="AEMQ"
- DO ^DIC
- KILL DIC
- +6 IF Y=-1
- GOTO X1
- +7 SET ATXSYS=+Y
- +8 QUIT
- +9 ;I Y="*" W !!,"Sorry, '*' is not allowed.
- +10 ;
- LOOK ; ENTRY POINT - LOOKUP USER RESPONSE; SET UTILITY NODES
- +1 SET DIC="^ICD9("
- 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 X3
- +3 IF ATXTYP="LOW"
- SET ATX("LOW")=$PIECE($SELECT(ATXSYS=1:$$ICDDX^ICDEX(+Y),1:$$ICDDX^ICDEX(+Y)),U,2)_" "
- +4 IF ATXTYP="LOW"
- IF ATXONE
- SET ATX("HI")=ATX("LOW")
- DO ^ATXCOD1
- +5 IF ATXTYP="HI"
- SET ATX("HI")=$PIECE($SELECT(ATXSYS=1:$$ICDDX^ICDEX(+Y),1:$$ICDDX^ICDEX(+Y)),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 ^ATXCOD1
- X3 QUIT
- +1 ;
- SETDIR ; ENTRY POINT - SETS HELP AND DIR FOR INIT SUBROUTINE OF ATXCODE
- +1 SET DIR(0)="FO"
- SET DIR("?",1)="Enter ICD diagnosis 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)="To select all codes in a set you can use a '*' wildcard. E.g. E11*, 250*"
- +5 SET DIR("?",7)="You can also ""de-select"" a code or range of codes by placing a ""-"" in"
- SET DIR("?",8)="front of it. (e.g. '-250.00' or '-250.01-250.91') Enter ""??"" to see"
- +6 SET DIR("?")="code ranges selected so far."
- +7 SET DIR("??")="^D ASK2^ATXCODE"
- +8 QUIT
- +9 ;
- 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^ATXCODE
- +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 ;
- STAR ;
- +1 IF $EXTRACT(X)="-"
- SET ATXSUB=1
- +2 NEW ATXTEMP
- +3 DO LST^ATXAPI(ATXSYS,80,$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 ^ATXCOD1
- +10 QUIT
- 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 " ?? 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
- +16 ;
- X2 QUIT
- +1 ;
- 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
- DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
- +1 IF $DATA(IOF)
- WRITE @IOF
- +2 NEW ATXX,ATXQ,ATXARR
- +3 ;W !!,"ICD codes in this range =>",!! W $P(ATX("LOW")," ") S ATXDFN=$O(^ICD9("BA",ATX("LOW"),"")) W ?9,$P(^ICD9(ATXDFN,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 ATXARR
- +6 DO LST^ATXAPI(ATXSYS,80,$$STRIP^XLFSTR(ATX("LOW"))_"-"_$$STRIP^XLFSTR(ATX("HI")),"CODE","ATXARR")
- +7 SET ATXX=""
- SET ATXQ=0
- FOR
- SET ATXX=$ORDER(ATXARR(ATXX))
- IF ATXX=""!($GET(ATXQ))
- QUIT
- Begin DoDot:1
- +8 IF $Y>(IOSL-2)
- DO EOP
- IF ATXQ
- QUIT
- +9 IF $PIECE(ATXARR(ATXX),U,2)=1
- WRITE !,ATXX,?12,$EXTRACT($PIECE($$ICDDX^ICDEX($PIECE(ATXARR(ATXX),U,1)),U,4),1,40),?60,$PIECE(ATXARR(ATXX),U,4)
- IF 1
- +10 IF '$TEST
- WRITE !,ATXX,?12,$EXTRACT($PIECE($$ICDDX^ICDEX($PIECE(ATXARR(ATXX),U,1)),U,4),1,40),?60,$PIECE(ATXARR(ATXX),U,4)
- End DoDot:1
- +11 NEW DIR
- +12 SET DIR(0)="E"
- SET DIR("A")="Press Enter to Continue <>"
- DO ^DIR
- +13 QUIT
- +14 ;
- 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 ;EP - 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 X4
- +5 ;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"),""))
- +6 NEW X,A,B,ATXN
- +7 SET ATXN=+Y
- +8 SET X=""
- FOR
- SET X=$ORDER(^ATXAX(ATXN,21,"B",X))
- IF X=""
- QUIT
- Begin DoDot:1
- +9 SET Y=0
- FOR
- SET Y=$ORDER(^ATXAX(ATXN,21,"B",X,Y))
- IF Y=""
- QUIT
- Begin DoDot:2
- +10 SET A=$PIECE(^ATXAX(ATXN,21,Y,0),U,1)
- SET B=$PIECE(^ATXAX(ATXN,21,Y,0),U,2)
- SET C=$PIECE(^ATXAX(ATXN,21,Y,0),U,3)
- +11 SET ATXTBLE(A)=B_U_C
- End DoDot:2
- End DoDot:1
- X4 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 ;
