AQAOCOD1 ; IHS/ORDC/LJF - MAINTAIN CODE RANGES IN TABLE ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;IHS/ORDC/LJF; copy 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
; put DEL subrtn into rtn ^AQAOCOD9
;
I 'AQAOSUB D ADD I 1
E D DEL^AQAOCOD9
D EOJ
Q
ADD ; SECTION FOR ADDING CODES TO TABLE
I '$D(AQAOTBL) S AQAOTBL(AQAO("LOW"))=AQAO("HI") G X1
S AQAODONE=0
S AQAOVAL="" F S AQAOVAL=$O(AQAOTBL(AQAOVAL)) Q:AQAOVAL="" D GETCASE,ADDPROC Q:AQAODONE
D:'AQAODONE SETRANGE
K AQAODONE,AQAOVAL,AQAOCASE
X1 Q
ADDPROC ; CASE SPECIFIC ADD PROCESSING
G @("ADD"_AQAOCASE)
ADD2 ;;
ADD3 ;;
ADD4 ;;
S AQAOTBL(AQAO("LOW"))=AQAOTBL(AQAOVAL)
K AQAOTBL(AQAOVAL)
ADD6 ;;
ADD7 ;;
ADD9 ;;
ADD10 ;;
S AQAODONE=1
Q
ADD11 ;;
ADD12 ;;
S AQAO("LOW")=AQAOVAL
ADD5 ;;
ADD8 ;;
K AQAOTBL(AQAOVAL)
Q
ADD1 ;;
I AQAOICD=9 I $O(^ICD9("BA",AQAO("HI")))=AQAOVAL,$E(AQAOVAL)=$E(AQAO("HI"))!(AQAOVAL&AQAO("HI")) S AQAOTBL(AQAO("LOW"))=AQAOTBL(AQAOVAL) K AQAOTBL(AQAOVAL) S AQAODONE=1
I AQAOICD=0 I $O(^ICD0("BA",AQAO("HI")))=AQAOVAL,$E(AQAOVAL)=$E(AQAO("HI"))!(AQAOVAL&AQAO("HI")) S AQAOTBL(AQAO("LOW"))=AQAOTBL(AQAOVAL) K AQAOTBL(AQAOVAL) S AQAODONE=1 ;IHS/ORDC/LJF code for ICD0
Q
ADD13 ;;
I AQAOICD=9 I $O(^ICD9("BA",AQAOTBL(AQAOVAL)))=AQAO("LOW"),$E(AQAOVAL)=$E(AQAO("LOW"))!(AQAOVAL&AQAO("LOW")) S AQAO("LOW")=AQAOVAL K AQAOTBL(AQAOVAL)
I AQAOICD=0 I $O(^ICD0("BA",AQAOTBL(AQAOVAL)))=AQAO("LOW"),$E(AQAOVAL)=$E(AQAO("LOW"))!(AQAOVAL&AQAO("LOW")) S AQAO("LOW")=AQAOVAL K AQAOTBL(AQAOVAL) ;IHS/ORDC/LJF code for ICD0
; continue
Q
SETRANGE ;
;;
SET1 ;;
SET5 ;;
SET8 ;;
SET11 ;;
SET12 ;;
SET13 ;;
S AQAOTBL(AQAO("LOW"))=AQAO("HI")
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
EOJ ;
K AQAOCASE,AQAODONE,AQAONEXT,AQAONE,AQAOVAL
Q
AQAOCOD1 ; IHS/ORDC/LJF - MAINTAIN CODE RANGES IN TABLE ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;IHS/ORDC/LJF; copy of rtn ^ATXCODE1 ;;4.2;Taxonomy;;MAR 19, 1991
+3 ; changes: changed namespacing from ATX to AQA
+4 ; added check of AQAOICD to determin if using ICD9 or ICD0
+5 ; put DEL subrtn into rtn ^AQAOCOD9
+6 ;
+7 IF 'AQAOSUB
DO ADD
IF 1
+8 IF '$TEST
DO DEL^AQAOCOD9
+9 DO EOJ
+10 QUIT
ADD ; SECTION FOR ADDING CODES TO TABLE
+1 IF '$DATA(AQAOTBL)
SET AQAOTBL(AQAO("LOW"))=AQAO("HI")
GOTO X1
+2 SET AQAODONE=0
+3 SET AQAOVAL=""
FOR
SET AQAOVAL=$ORDER(AQAOTBL(AQAOVAL))
IF AQAOVAL=""
QUIT
DO GETCASE
DO ADDPROC
IF AQAODONE
QUIT
+4 IF 'AQAODONE
DO SETRANGE
+5 KILL AQAODONE,AQAOVAL,AQAOCASE
X1 QUIT
ADDPROC ; CASE SPECIFIC ADD PROCESSING
+1 GOTO @("ADD"_AQAOCASE)
ADD2 ;;
ADD3 ;;
ADD4 ;;
+1 SET AQAOTBL(AQAO("LOW"))=AQAOTBL(AQAOVAL)
+2 KILL AQAOTBL(AQAOVAL)
ADD6 ;;
ADD7 ;;
ADD9 ;;
ADD10 ;;
+1 SET AQAODONE=1
+2 QUIT
ADD11 ;;
ADD12 ;;
+1 SET AQAO("LOW")=AQAOVAL
ADD5 ;;
ADD8 ;;
+1 KILL AQAOTBL(AQAOVAL)
+2 QUIT
ADD1 ;;
+1 IF AQAOICD=9
IF $ORDER(^ICD9("BA",AQAO("HI")))=AQAOVAL
IF $EXTRACT(AQAOVAL)=$EXTRACT(AQAO("HI"))!(AQAOVAL&AQAO("HI"))
SET AQAOTBL(AQAO("LOW"))=AQAOTBL(AQAOVAL)
KILL AQAOTBL(AQAOVAL)
SET AQAODONE=1
+2 ;IHS/ORDC/LJF code for ICD0
IF AQAOICD=0
IF $ORDER(^ICD0("BA",AQAO("HI")))=AQAOVAL
IF $EXTRACT(AQAOVAL)=$EXTRACT(AQAO("HI"))!(AQAOVAL&AQAO("HI"))
SET AQAOTBL(AQAO("LOW"))=AQAOTBL(AQAOVAL)
KILL AQAOTBL(AQAOVAL)
SET AQAODONE=1
+3 QUIT
ADD13 ;;
+1 IF AQAOICD=9
IF $ORDER(^ICD9("BA",AQAOTBL(AQAOVAL)))=AQAO("LOW")
IF $EXTRACT(AQAOVAL)=$EXTRACT(AQAO("LOW"))!(AQAOVAL&AQAO("LOW"))
SET AQAO("LOW")=AQAOVAL
KILL AQAOTBL(AQAOVAL)
+2 ;IHS/ORDC/LJF code for ICD0
IF AQAOICD=0
IF $ORDER(^ICD0("BA",AQAOTBL(AQAOVAL)))=AQAO("LOW")
IF $EXTRACT(AQAOVAL)=$EXTRACT(AQAO("LOW"))!(AQAOVAL&AQAO("LOW"))
SET AQAO("LOW")=AQAOVAL
KILL AQAOTBL(AQAOVAL)
+3 ; continue
+4 QUIT
SETRANGE ;
+1 ;;
SET1 ;;
SET5 ;;
SET8 ;;
SET11 ;;
SET12 ;;
SET13 ;;
+1 SET AQAOTBL(AQAO("LOW"))=AQAO("HI")
+2 QUIT
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
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
EOJ ;
+1 KILL AQAOCASE,AQAODONE,AQAONEXT,AQAONE,AQAOVAL
+2 QUIT
