AQAOCOD9.m

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