ATXTAXJ ; IHS/CMI/LAB - CODE RANGES IN TABLE ;
;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
;
I 'ATXSUB D ADD I 1
E D DEL
D EOJ
Q
;
ADD ; SECTION FOR ADDING CODES TO TABLE
I '$D(ATXTBLE) S ATXTBLE(ATX("LOW"))=ATX("HI")_U_ATXSYS G X1
S ATXDONE=0
S ATXVAL="" F S ATXVAL=$O(ATXTBLE(ATXVAL)) Q:ATXVAL="" I $P(ATXTBLE(ATXVAL),U,2)=ATXSYS D GETCASE,ADDPROC Q:ATXDONE
D:'ATXDONE SETRANGE
K ATXDONE,ATXVAL,ATXCASE
X1 Q
;
ADDPROC ; CASE SPECIFIC ADD PROCESSING
G @("ADD"_ATXCASE)
ADD2 ;;
ADD3 ;;
ADD4 ;;
S ATXTBLE(ATX("LOW"))=ATXTBLE(ATXVAL)
K ATXTBLE(ATXVAL)
ADD6 ;;
ADD7 ;;
ADD9 ;;
ADD10 ;;
S ATXDONE=1
Q
ADD11 ;;
ADD12 ;;
S ATX("LOW")=ATXVAL
ADD5 ;;
ADD8 ;;
K ATXTBLE(ATXVAL)
Q
ADD1 ;;
I $O(^ICD0("BA",ATX("HI")))=ATXVAL,$E(ATXVAL)=$E(ATX("HI"))!(ATXVAL&ATX("HI")) S ATXTBLE(ATX("LOW"))=ATXTBLE(ATXVAL) K ATXTBLE(ATXVAL) S ATXDONE=1
Q
ADD13 ;;
I $O(^ICD0("BA",ATXTBLE(ATXVAL)))=ATX("LOW"),$E(ATXVAL)=$E(ATX("LOW"))!(ATXVAL&ATX("LOW")) S ATX("LOW")=ATXVAL K ATXTBLE(ATXVAL)
; continue
Q
;
SETRANGE ;
;;
SET1 ;;
SET5 ;;
SET8 ;;
SET11 ;;
SET12 ;;
SET13 ;;
S ATXTBLE(ATX("LOW"))=ATX("HI")_U_ATXSYS
Q
;
DEL ; SECTION FOR DELETING CODES FROM TABLE
I '$D(ATXTBLE) G X2
S ATXDONE=0
S ATXVAL="" F S ATXVAL=$O(ATXTBLE(ATXVAL)) Q:ATXVAL="" I $P(ATXTBLE(ATXVAL),U,2)=ATXSYS D GETCASE,DELPROC Q:ATXDONE
X2 Q
;
DELPROC ;CASE SPECIFIC DEL PROCESSING
G @("DEL"_ATXCASE)
DEL2 ;;
I ATX("HI")=ATXTBLE(ATXVAL) K ATXTBLE(ATXVAL)
E S ATXTBLE($O(^ICD0("BA",ATX("HI"))))=ATXTBLE(ATXVAL)_U_ATXSYS K ATXTBLE(ATXVAL)
S ATXDONE=1
Q
;
DEL3 ;;
DEL6 ;;
S ATXTBLE($O(^ICD0("BA",ATX("HI"))))=ATXTBLE(ATXVAL)_U_ATXSYS K ATXTBLE(ATXVAL)
S ATXDONE=1
Q
;
DEL4 ;;
DEL5 ;;
DEL7 ;;
DEL8 ;;
K ATXTBLE(ATXVAL)
I ATXCASE'=8,ATXCASE'=5 S ATXDONE=1
Q
;
DEL10 ;;
DEL11 ;;
DEL12 ;;
D @$S($E(ATXTBLE(ATXVAL))?1N:"NUMBER",1:"LETTER")
S ATXTBLE(ATXVAL)=ATX("NEWHI")_U_ATXSYS
I ATXCASE=10 S ATXDONE=1
Q
;
DEL9 ;;
D @$S($E(ATXTBLE(ATXVAL))?1N:"NUMBER",1:"LETTER")
S ATXTBLE($O(^ICD0("BA",ATX("HI"))))=ATXTBLE(ATXVAL)_U_ATXSYS
S ATXTBLE(ATXVAL)=ATX("NEWHI")_U_ATXSYS
S ATXDONE=1
Q
;
DEL1 ;;
DEL13 ;;
Q
;
GETCASE ; SUBROUTINE TO DETERMINE ATXCASE # FROM INPUT CODE RANGE
S ATX("TLOW")=ATXVAL,ATX("THI")=$P(ATXTBLE(ATXVAL),U,1) ;_U_ATXSYS
D CASEA:ATX("TLOW")]ATX("LOW"),CASEB:ATX("LOW")=ATX("TLOW"),CASEC:ATX("LOW")]ATX("TLOW")
K ATX("TLOW"),ATX("THI")
Q
;
CASEA ;
I ATX("HI")]ATX("TLOW") S ATXCASE=$S(ATX("THI")]ATX("HI"):3,ATX("HI")=ATX("THI"):4,1:5)
E S ATXCASE=$S(ATX("TLOW")]ATX("HI"):1,1:2)
Q
;
CASEB ;
S ATXCASE=$S(ATX("THI")]ATX("HI"):6,ATX("HI")=ATX("THI"):7,1:8)
Q
;
CASEC ;
I ATX("THI")]ATX("LOW") S ATXCASE=$S(ATX("THI")]ATX("HI"):9,ATX("HI")=ATX("THI"):10,1:11)
E S ATXCASE=$S(ATX("LOW")=ATX("THI"):12,1:13)
Q
;
NUMBER ;
S ATX("CODE")=ATX("LOW")-5 F Q:ATX("LOW")]$O(^ICD0("BA",ATX("CODE")_" ")) S ATX("CODE")=ATX("CODE")-5
S ATX("CODE")=$O(^ICD0("BA",ATX("CODE")_" ")) F S ATX("NEWHI")=ATX("CODE"),ATX("CODE")=$O(^ICD0("BA",ATX("CODE"))) Q:ATX("CODE")=ATX("LOW")
Q
;
LETTER ;
S ATX("LET")=$E(ATX("LOW"))_" " F S ATX("NEWHI")=$S($L(ATX("LET"))>2:ATX("LET"),1:ATX("LOW")),ATX("LET")=$O(^ICD0("BA",ATX("LET"))) Q:ATX("LET")=ATX("LOW")
Q
EOJ ;
K ATXCASE,ATXDONE,ATXNEXT,ATXONE,ATXVAL
Q
;
ATXTAXJ ; IHS/CMI/LAB - CODE RANGES IN TABLE ;
+1 ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
+2 ;
+3 IF 'ATXSUB
DO ADD
IF 1
+4 IF '$TEST
DO DEL
+5 DO EOJ
+6 QUIT
+7 ;
ADD ; SECTION FOR ADDING CODES TO TABLE
+1 IF '$DATA(ATXTBLE)
SET ATXTBLE(ATX("LOW"))=ATX("HI")_U_ATXSYS
GOTO X1
+2 SET ATXDONE=0
+3 SET ATXVAL=""
FOR
SET ATXVAL=$ORDER(ATXTBLE(ATXVAL))
IF ATXVAL=""
QUIT
IF $PIECE(ATXTBLE(ATXVAL),U,2)=ATXSYS
DO GETCASE
DO ADDPROC
IF ATXDONE
QUIT
+4 IF 'ATXDONE
DO SETRANGE
+5 KILL ATXDONE,ATXVAL,ATXCASE
X1 QUIT
+1 ;
ADDPROC ; CASE SPECIFIC ADD PROCESSING
+1 GOTO @("ADD"_ATXCASE)
ADD2 ;;
ADD3 ;;
ADD4 ;;
+1 SET ATXTBLE(ATX("LOW"))=ATXTBLE(ATXVAL)
+2 KILL ATXTBLE(ATXVAL)
ADD6 ;;
ADD7 ;;
ADD9 ;;
ADD10 ;;
+1 SET ATXDONE=1
+2 QUIT
ADD11 ;;
ADD12 ;;
+1 SET ATX("LOW")=ATXVAL
ADD5 ;;
ADD8 ;;
+1 KILL ATXTBLE(ATXVAL)
+2 QUIT
ADD1 ;;
+1 IF $ORDER(^ICD0("BA",ATX("HI")))=ATXVAL
IF $EXTRACT(ATXVAL)=$EXTRACT(ATX("HI"))!(ATXVAL&ATX("HI"))
SET ATXTBLE(ATX("LOW"))=ATXTBLE(ATXVAL)
KILL ATXTBLE(ATXVAL)
SET ATXDONE=1
+2 QUIT
ADD13 ;;
+1 IF $ORDER(^ICD0("BA",ATXTBLE(ATXVAL)))=ATX("LOW")
IF $EXTRACT(ATXVAL)=$EXTRACT(ATX("LOW"))!(ATXVAL&ATX("LOW"))
SET ATX("LOW")=ATXVAL
KILL ATXTBLE(ATXVAL)
+2 ; continue
+3 QUIT
+4 ;
SETRANGE ;
+1 ;;
SET1 ;;
SET5 ;;
SET8 ;;
SET11 ;;
SET12 ;;
SET13 ;;
+1 SET ATXTBLE(ATX("LOW"))=ATX("HI")_U_ATXSYS
+2 QUIT
+3 ;
DEL ; SECTION FOR DELETING CODES FROM TABLE
+1 IF '$DATA(ATXTBLE)
GOTO X2
+2 SET ATXDONE=0
+3 SET ATXVAL=""
FOR
SET ATXVAL=$ORDER(ATXTBLE(ATXVAL))
IF ATXVAL=""
QUIT
IF $PIECE(ATXTBLE(ATXVAL),U,2)=ATXSYS
DO GETCASE
DO DELPROC
IF ATXDONE
QUIT
X2 QUIT
+1 ;
DELPROC ;CASE SPECIFIC DEL PROCESSING
+1 GOTO @("DEL"_ATXCASE)
DEL2 ;;
+1 IF ATX("HI")=ATXTBLE(ATXVAL)
KILL ATXTBLE(ATXVAL)
+2 IF '$TEST
SET ATXTBLE($ORDER(^ICD0("BA",ATX("HI"))))=ATXTBLE(ATXVAL)_U_ATXSYS
KILL ATXTBLE(ATXVAL)
+3 SET ATXDONE=1
+4 QUIT
+5 ;
DEL3 ;;
DEL6 ;;
+1 SET ATXTBLE($ORDER(^ICD0("BA",ATX("HI"))))=ATXTBLE(ATXVAL)_U_ATXSYS
KILL ATXTBLE(ATXVAL)
+2 SET ATXDONE=1
+3 QUIT
+4 ;
DEL4 ;;
DEL5 ;;
DEL7 ;;
DEL8 ;;
+1 KILL ATXTBLE(ATXVAL)
+2 IF ATXCASE'=8
IF ATXCASE'=5
SET ATXDONE=1
+3 QUIT
+4 ;
DEL10 ;;
DEL11 ;;
DEL12 ;;
+1 DO @$SELECT($EXTRACT(ATXTBLE(ATXVAL))?1N:"NUMBER",1:"LETTER")
+2 SET ATXTBLE(ATXVAL)=ATX("NEWHI")_U_ATXSYS
+3 IF ATXCASE=10
SET ATXDONE=1
+4 QUIT
+5 ;
DEL9 ;;
+1 DO @$SELECT($EXTRACT(ATXTBLE(ATXVAL))?1N:"NUMBER",1:"LETTER")
+2 SET ATXTBLE($ORDER(^ICD0("BA",ATX("HI"))))=ATXTBLE(ATXVAL)_U_ATXSYS
+3 SET ATXTBLE(ATXVAL)=ATX("NEWHI")_U_ATXSYS
+4 SET ATXDONE=1
+5 QUIT
+6 ;
DEL1 ;;
DEL13 ;;
+1 QUIT
+2 ;
GETCASE ; SUBROUTINE TO DETERMINE ATXCASE # FROM INPUT CODE RANGE
+1 ;_U_ATXSYS
SET ATX("TLOW")=ATXVAL
SET ATX("THI")=$PIECE(ATXTBLE(ATXVAL),U,1)
+2 IF ATX("TLOW")]ATX("LOW")
DO CASEA
IF ATX("LOW")=ATX("TLOW")
DO CASEB
IF ATX("LOW")]ATX("TLOW")
DO CASEC
+3 KILL ATX("TLOW"),ATX("THI")
+4 QUIT
+5 ;
CASEA ;
+1 IF ATX("HI")]ATX("TLOW")
SET ATXCASE=$SELECT(ATX("THI")]ATX("HI"):3,ATX("HI")=ATX("THI"):4,1:5)
+2 IF '$TEST
SET ATXCASE=$SELECT(ATX("TLOW")]ATX("HI"):1,1:2)
+3 QUIT
+4 ;
CASEB ;
+1 SET ATXCASE=$SELECT(ATX("THI")]ATX("HI"):6,ATX("HI")=ATX("THI"):7,1:8)
+2 QUIT
+3 ;
CASEC ;
+1 IF ATX("THI")]ATX("LOW")
SET ATXCASE=$SELECT(ATX("THI")]ATX("HI"):9,ATX("HI")=ATX("THI"):10,1:11)
+2 IF '$TEST
SET ATXCASE=$SELECT(ATX("LOW")=ATX("THI"):12,1:13)
+3 QUIT
+4 ;
NUMBER ;
+1 SET ATX("CODE")=ATX("LOW")-5
FOR
IF ATX("LOW")]$ORDER(^ICD0("BA",ATX("CODE")_" "))
QUIT
SET ATX("CODE")=ATX("CODE")-5
+2 SET ATX("CODE")=$ORDER(^ICD0("BA",ATX("CODE")_" "))
FOR
SET ATX("NEWHI")=ATX("CODE")
SET ATX("CODE")=$ORDER(^ICD0("BA",ATX("CODE")))
IF ATX("CODE")=ATX("LOW")
QUIT
+3 QUIT
+4 ;
LETTER ;
+1 SET ATX("LET")=$EXTRACT(ATX("LOW"))_" "
FOR
SET ATX("NEWHI")=$SELECT($LENGTH(ATX("LET"))>2:ATX("LET"),1:ATX("LOW"))
SET ATX("LET")=$ORDER(^ICD0("BA",ATX("LET")))
IF ATX("LET")=ATX("LOW")
QUIT
+2 QUIT
EOJ ;
+1 KILL ATXCASE,ATXDONE,ATXNEXT,ATXONE,ATXVAL
+2 QUIT
+3 ;
