AQAOCOD9 ; IHS/ORDC/LJF - MAINTAIN CODE RANGES IN TABLE ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;IHS/ORDC/LJF; copy of DEL subrtn of rtn ^ATXCODE1
; ;4.2;Taxonomy;;MAR 19, 1991
; changes: changed namespacing from ATX to AQA
; added check of AQAOICD to determin if using ICD9 or ICD0
;
DEL ;ENTRY POINT - SECTION FOR DELETING CODES FROM TABLE
I '$D(AQAOTBL) G X2
S AQAODONE=0
S AQAOVAL="" F S AQAOVAL=$O(AQAOTBL(AQAOVAL)) Q:AQAOVAL="" D GETCASE,DELPROC Q:AQAODONE
X2 Q
DELPROC ;CASE SPECIFIC DEL PROCESSING
G @("DEL"_AQAOCASE)
DEL2 ;;
I AQAOICD=0 G DEL2A ;IHS/ORDC/LJF code for ICD0
I AQAO("HI")=AQAOTBL(AQAOVAL) K AQAOTBL(AQAOVAL)
E S AQAOTBL($O(^ICD9("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL) K AQAOTBL(AQAOVAL)
S AQAODONE=1
Q
DEL2A ;; for procedures
I AQAO("HI")=AQAOTBL(AQAOVAL) K AQAOTBL(AQAOVAL)
E S AQAOTBL($O(^ICD0("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL) K AQAOTBL(AQAOVAL)
S AQAODONE=1
Q
DEL3 ;;
DEL6 ;;
I AQAOICD=9 S AQAOTBL($O(^ICD9("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL) K AQAOTBL(AQAOVAL)
I AQAOICD=0 S AQAOTBL($O(^ICD0("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL) K AQAOTBL(AQAOVAL) ;IHS/ORDC/LJF code for ICD0
S AQAODONE=1
Q
DEL4 ;;
DEL5 ;;
DEL7 ;;
DEL8 ;;
K AQAOTBL(AQAOVAL)
I AQAOCASE'=8,AQAOCASE'=5 S AQAODONE=1
Q
DEL10 ;;
DEL11 ;;
DEL12 ;;
D @$S($E(AQAOTBL(AQAOVAL))?1N:"NUMBER",1:"LETTER")
S AQAOTBL(AQAOVAL)=AQAO("NEWHI")
I AQAOCASE=10 S AQAODONE=1
Q
DEL9 ;;
D @$S($E(AQAOTBL(AQAOVAL))?1N:"NUMBER",1:"LETTER")
I AQAOICD=9 S AQAOTBL($O(^ICD9("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL)
I AQAOICD=0 S AQAOTBL($O(^ICD0("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL)
S AQAOTBL(AQAOVAL)=AQAO("NEWHI")
S AQAODONE=1
Q
DEL1 ;;
DEL13 ;;
Q
;
;
GETCASE ; SUBROUTINE TO DETERMINE AQAOCASE # FROM INPUT CODE RANGE
S AQAO("TLOW")=AQAOVAL,AQAO("THI")=AQAOTBL(AQAOVAL)
D CASEA:AQAO("TLOW")]AQAO("LOW"),CASEB:AQAO("LOW")=AQAO("TLOW"),CASEC:AQAO("LOW")]AQAO("TLOW")
K AQAO("TLOW"),AQAO("THI")
Q
;
;
CASEA ;
I AQAO("HI")]AQAO("TLOW") S AQAOCASE=$S(AQAO("THI")]AQAO("HI"):3,AQAO("HI")=AQAO("THI"):4,1:5)
E S AQAOCASE=$S(AQAO("TLOW")]AQAO("HI"):1,1:2)
Q
CASEB ;
S AQAOCASE=$S(AQAO("THI")]AQAO("HI"):6,AQAO("HI")=AQAO("THI"):7,1:8)
Q
CASEC ;
I AQAO("THI")]AQAO("LOW") S AQAOCASE=$S(AQAO("THI")]AQAO("HI"):9,AQAO("HI")=AQAO("THI"):10,1:11)
E S AQAOCASE=$S(AQAO("LOW")=AQAO("THI"):12,1:13)
Q
NUMBER ;
I AQAOICD=0 G NUMBER2 ;IHS/ORDC/LJF code for procedures
S AQAO("CODE")=AQAO("LOW")-5 F Q:AQAO("LOW")]$O(^ICD9("BA",AQAO("CODE")_" ")) S AQAO("CODE")=AQAO("CODE")-5
S AQAO("CODE")=$O(^ICD9("BA",AQAO("CODE")_" ")) F S AQAO("NEWHI")=AQAO("CODE"),AQAO("CODE")=$O(^ICD9("BA",AQAO("CODE"))) Q:AQAO("CODE")=AQAO("LOW")
Q
NUMBER2 ; CODE FOR PROCEDURES
S AQAO("CODE")=AQAO("LOW")-5 F Q:AQAO("LOW")]$O(^ICD0("BA",AQAO("CODE")_" ")) S AQAO("CODE")=AQAO("CODE")-5 ;IHS/ORDC/LJF code for ICD0
S AQAO("CODE")=$O(^ICD0("BA",AQAO("CODE")_" ")) F S AQAO("NEWHI")=AQAO("CODE"),AQAO("CODE")=$O(^ICD0("BA",AQAO("CODE"))) Q:AQAO("CODE")=AQAO("LOW") ;IHS/ORDC/LJF code for ICD0
Q
LETTER ;
I AQAOICD=9 S AQAO("LET")=$E(AQAO("LOW"))_" " F S AQAO("NEWHI")=$S($L(AQAO("LET"))>2:AQAO("LET"),1:AQAO("LOW")),AQAO("LET")=$O(^ICD9("BA",AQAO("LET"))) Q:AQAO("LET")=AQAO("LOW")
I AQAOICD=0 S AQAO("LET")=$E(AQAO("LOW"))_" " F S AQAO("NEWHI")=$S($L(AQAO("LET"))>2:AQAO("LET"),1:AQAO("LOW")),AQAO("LET")=$O(^ICD0("BA",AQAO("LET"))) Q:AQAO("LET")=AQAO("LOW") ;IHS/ORDC/LJF code for ICD0
S AQAO("LET")=$E(AQAO("LOW"))_" " F S AQAO("NEWHI")=$S($L(AQAO("LET"))>2:AQAO("LET"),1:AQAO("LOW")),AQAO("LET")=$O(@(AQAOFL_"(""BA"","_AQAO("LET")_")")) Q:AQAO("LET")=AQAO("LOW")
Q
AQAOCOD9 ; IHS/ORDC/LJF - MAINTAIN CODE RANGES IN TABLE ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;IHS/ORDC/LJF; copy of DEL subrtn of rtn ^ATXCODE1
+3 ; ;4.2;Taxonomy;;MAR 19, 1991
+4 ; changes: changed namespacing from ATX to AQA
+5 ; added check of AQAOICD to determin if using ICD9 or ICD0
+6 ;
DEL ;ENTRY POINT - SECTION FOR DELETING CODES FROM TABLE
+1 IF '$DATA(AQAOTBL)
GOTO X2
+2 SET AQAODONE=0
+3 SET AQAOVAL=""
FOR
SET AQAOVAL=$ORDER(AQAOTBL(AQAOVAL))
IF AQAOVAL=""
QUIT
DO GETCASE
DO DELPROC
IF AQAODONE
QUIT
X2 QUIT
DELPROC ;CASE SPECIFIC DEL PROCESSING
+1 GOTO @("DEL"_AQAOCASE)
DEL2 ;;
+1 ;IHS/ORDC/LJF code for ICD0
IF AQAOICD=0
GOTO DEL2A
+2 IF AQAO("HI")=AQAOTBL(AQAOVAL)
KILL AQAOTBL(AQAOVAL)
+3 IF '$TEST
SET AQAOTBL($ORDER(^ICD9("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL)
KILL AQAOTBL(AQAOVAL)
+4 SET AQAODONE=1
+5 QUIT
DEL2A ;; for procedures
+1 IF AQAO("HI")=AQAOTBL(AQAOVAL)
KILL AQAOTBL(AQAOVAL)
+2 IF '$TEST
SET AQAOTBL($ORDER(^ICD0("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL)
KILL AQAOTBL(AQAOVAL)
+3 SET AQAODONE=1
+4 QUIT
DEL3 ;;
DEL6 ;;
+1 IF AQAOICD=9
SET AQAOTBL($ORDER(^ICD9("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL)
KILL AQAOTBL(AQAOVAL)
+2 ;IHS/ORDC/LJF code for ICD0
IF AQAOICD=0
SET AQAOTBL($ORDER(^ICD0("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL)
KILL AQAOTBL(AQAOVAL)
+3 SET AQAODONE=1
+4 QUIT
DEL4 ;;
DEL5 ;;
DEL7 ;;
DEL8 ;;
+1 KILL AQAOTBL(AQAOVAL)
+2 IF AQAOCASE'=8
IF AQAOCASE'=5
SET AQAODONE=1
+3 QUIT
DEL10 ;;
DEL11 ;;
DEL12 ;;
+1 DO @$SELECT($EXTRACT(AQAOTBL(AQAOVAL))?1N:"NUMBER",1:"LETTER")
+2 SET AQAOTBL(AQAOVAL)=AQAO("NEWHI")
+3 IF AQAOCASE=10
SET AQAODONE=1
+4 QUIT
DEL9 ;;
+1 DO @$SELECT($EXTRACT(AQAOTBL(AQAOVAL))?1N:"NUMBER",1:"LETTER")
+2 IF AQAOICD=9
SET AQAOTBL($ORDER(^ICD9("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL)
+3 IF AQAOICD=0
SET AQAOTBL($ORDER(^ICD0("BA",AQAO("HI"))))=AQAOTBL(AQAOVAL)
+4 SET AQAOTBL(AQAOVAL)=AQAO("NEWHI")
+5 SET AQAODONE=1
+6 QUIT
DEL1 ;;
DEL13 ;;
+1 QUIT
+2 ;
+3 ;
GETCASE ; SUBROUTINE TO DETERMINE AQAOCASE # FROM INPUT CODE RANGE
+1 SET AQAO("TLOW")=AQAOVAL
SET AQAO("THI")=AQAOTBL(AQAOVAL)
+2 IF AQAO("TLOW")]AQAO("LOW")
DO CASEA
IF AQAO("LOW")=AQAO("TLOW")
DO CASEB
IF AQAO("LOW")]AQAO("TLOW")
DO CASEC
+3 KILL AQAO("TLOW"),AQAO("THI")
+4 QUIT
+5 ;
+6 ;
CASEA ;
+1 IF AQAO("HI")]AQAO("TLOW")
SET AQAOCASE=$SELECT(AQAO("THI")]AQAO("HI"):3,AQAO("HI")=AQAO("THI"):4,1:5)
+2 IF '$TEST
SET AQAOCASE=$SELECT(AQAO("TLOW")]AQAO("HI"):1,1:2)
+3 QUIT
CASEB ;
+1 SET AQAOCASE=$SELECT(AQAO("THI")]AQAO("HI"):6,AQAO("HI")=AQAO("THI"):7,1:8)
+2 QUIT
CASEC ;
+1 IF AQAO("THI")]AQAO("LOW")
SET AQAOCASE=$SELECT(AQAO("THI")]AQAO("HI"):9,AQAO("HI")=AQAO("THI"):10,1:11)
+2 IF '$TEST
SET AQAOCASE=$SELECT(AQAO("LOW")=AQAO("THI"):12,1:13)
+3 QUIT
NUMBER ;
+1 ;IHS/ORDC/LJF code for procedures
IF AQAOICD=0
GOTO NUMBER2
+2 SET AQAO("CODE")=AQAO("LOW")-5
FOR
IF AQAO("LOW")]$ORDER(^ICD9("BA",AQAO("CODE")_" "))
QUIT
SET AQAO("CODE")=AQAO("CODE")-5
+3 SET AQAO("CODE")=$ORDER(^ICD9("BA",AQAO("CODE")_" "))
FOR
SET AQAO("NEWHI")=AQAO("CODE")
SET AQAO("CODE")=$ORDER(^ICD9("BA",AQAO("CODE")))
IF AQAO("CODE")=AQAO("LOW")
QUIT
+4 QUIT
NUMBER2 ; CODE FOR PROCEDURES
+1 ;IHS/ORDC/LJF code for ICD0
SET AQAO("CODE")=AQAO("LOW")-5
FOR
IF AQAO("LOW")]$ORDER(^ICD0("BA",AQAO("CODE")_" "))
QUIT
SET AQAO("CODE")=AQAO("CODE")-5
+2 ;IHS/ORDC/LJF code for ICD0
SET AQAO("CODE")=$ORDER(^ICD0("BA",AQAO("CODE")_" "))
FOR
SET AQAO("NEWHI")=AQAO("CODE")
SET AQAO("CODE")=$ORDER(^ICD0("BA",AQAO("CODE")))
IF AQAO("CODE")=AQAO("LOW")
QUIT
+3 QUIT
LETTER ;
+1 IF AQAOICD=9
SET AQAO("LET")=$EXTRACT(AQAO("LOW"))_" "
FOR
SET AQAO("NEWHI")=$SELECT($LENGTH(AQAO("LET"))>2:AQAO("LET"),1:AQAO("LOW"))
SET AQAO("LET")=$ORDER(^ICD9("BA",AQAO("LET")))
IF AQAO("LET")=AQAO("LOW")
QUIT
+2 ;IHS/ORDC/LJF code for ICD0
IF AQAOICD=0
SET AQAO("LET")=$EXTRACT(AQAO("LOW"))_" "
FOR
SET AQAO("NEWHI")=$SELECT($LENGTH(AQAO("LET"))>2:AQAO("LET"),1:AQAO("LOW"))
SET AQAO("LET")=$ORDER(^ICD0("BA",AQAO("LET")))
IF AQAO("LET")=AQAO("LOW")
QUIT
+3 SET AQAO("LET")=$EXTRACT(AQAO("LOW"))_" "
FOR
SET AQAO("NEWHI")=$SELECT($LENGTH(AQAO("LET"))>2:AQAO("LET"),1:AQAO("LOW"))
SET AQAO("LET")=$ORDER(@(AQAOFL_"(""BA"","_AQAO("LET")_")"))
IF AQAO("LET")=AQAO("LOW")
QUIT
+4 QUIT
