APCDFQA5.m

APCDFQA5 ; IHS/CMI/LAB - MAINTAIN CODE RANGES IN TABLE ; 24 Jul 2012  5:04 PM

 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 ;

 I 'APCDSUB D ADD I 1

 E  D DEL

 D EOJ

 Q

 ;

ADD ; SECTION FOR ADDING CODES TO TABLE

 I '$D(APCDTABL) S APCDTABL(APCD("LOW"))=APCD("HI")_U_APCDSYS G X1

 S APCDDONE=0

 S APCDVAL="" F  S APCDVAL=$O(APCDTABL(APCDVAL)) Q:APCDVAL=""   I $P(APCDTABL(APCDVAL),U,2)=APCDSYS D GETCASE,ADDPROC Q:APCDDONE

 D:'APCDDONE SETRANGE

 K APCDDONE,APCDVAL,APCDCASE

X1 Q

 ;

ADDPROC ; CASE SPECIFIC ADD PROCESSING

 G @("ADD"_APCDCASE)

ADD2 ;;

ADD3 ;;

ADD4 ;;

 S APCDTABL(APCD("LOW"))=APCDTABL(APCDVAL)

 K APCDTABL(APCDVAL)

ADD6 ;;

ADD7 ;;

ADD9 ;;

ADD10 ;;

 S APCDDONE=1

 Q

ADD11 ;;

ADD12 ;;

 S APCD("LOW")=APCDVAL

ADD5 ;;

ADD8 ;;

 K APCDTABL(APCDVAL)

 Q

ADD1 ;;

 I $O(^ICD9("BA",APCD("HI")))=APCDVAL,$E(APCDVAL)=$E(APCD("HI"))!(APCDVAL&APCD("HI")) S APCDTABL(APCD("LOW"))=APCDTABL(APCDVAL) K APCDTABL(APCDVAL) S APCDDONE=1

 Q

ADD13 ;;

 I $O(^ICD9("BA",APCDTABL(APCDVAL)))=APCD("LOW"),$E(APCDVAL)=$E(APCD("LOW"))!(APCDVAL&APCD("LOW")) S APCD("LOW")=APCDVAL K APCDTABL(APCDVAL)

 ; continue

 Q

 ;

SETRANGE ;

 ;;

SET1 ;;

SET5 ;;

SET8 ;;

SET11 ;;

SET12 ;;

SET13 ;;

 S APCDTABL(APCD("LOW"))=APCD("HI")_U_APCDSYS

 Q

 ;

DEL ; SECTION FOR DELETING CODES FROM TABLE

 I '$D(APCDTABL) G X2

 S APCDDONE=0

 S APCDVAL="" F  S APCDVAL=$O(APCDTABL(APCDVAL)) Q:APCDVAL=""  I $P(APCDTABL(APCDVAL),U,2)=APCDSYS D GETCASE,DELPROC Q:APCDDONE

X2 Q

 ;

DELPROC ;CASE SPECIFIC DEL PROCESSING

 G @("DEL"_APCDCASE)

DEL2 ;;

 I APCD("HI")=APCDTABL(APCDVAL) K APCDTABL(APCDVAL)

 E  S APCDTABL($O(^ICD9("BA",APCD("HI"))))=APCDTABL(APCDVAL)_U_APCDSYS K APCDTABL(APCDVAL)

 S APCDDONE=1

 Q

 ;

DEL3 ;;

DEL6 ;;

 S APCDTABL($O(^ICD9("BA",APCD("HI"))))=APCDTABL(APCDVAL)_U_APCDSYS K APCDTABL(APCDVAL)

 S APCDDONE=1

 Q

 ;

DEL4 ;;

DEL5 ;;

DEL7 ;;

DEL8 ;;

 K APCDTABL(APCDVAL)

 I APCDCASE'=8,APCDCASE'=5 S APCDDONE=1

 Q

 ;

DEL10 ;;

DEL11 ;;

DEL12 ;;

 D @$S($E(APCDTABL(APCDVAL))?1N:"NUMBER",1:"LETTER")

 S APCDTABL(APCDVAL)=APCD("NEWHI")_U_APCDSYS

 I APCDCASE=10 S APCDDONE=1

 Q

 ;

DEL9 ;;

 D @$S($E(APCDTABL(APCDVAL))?1N:"NUMBER",1:"LETTER")

 S APCDTABL($O(^ICD9("BA",APCD("HI"))))=APCDTABL(APCDVAL)_U_APCDSYS

 S APCDTABL(APCDVAL)=APCD("NEWHI")_U_APCDSYS

 S APCDDONE=1

 Q

 ;

DEL1 ;;

DEL13 ;;

 Q

 ;

GETCASE ; SUBROUTINE TO DETERMINE APCDCASE # FROM INPUT CODE RANGE

 S APCD("TLOW")=APCDVAL,APCD("THI")=$P(APCDTABL(APCDVAL),U,1)  ;_U_APCDSYS

 D CASEA:APCD("TLOW")]APCD("LOW"),CASEB:APCD("LOW")=APCD("TLOW"),CASEC:APCD("LOW")]APCD("TLOW")

 K APCD("TLOW"),APCD("THI")

 Q

 ;

CASEA ;

 I APCD("HI")]APCD("TLOW") S APCDCASE=$S(APCD("THI")]APCD("HI"):3,APCD("HI")=APCD("THI"):4,1:5)

 E  S APCDCASE=$S(APCD("TLOW")]APCD("HI"):1,1:2)

 Q

 ;

CASEB ;

 S APCDCASE=$S(APCD("THI")]APCD("HI"):6,APCD("HI")=APCD("THI"):7,1:8)

 Q

 ;

CASEC ;

 I APCD("THI")]APCD("LOW") S APCDCASE=$S(APCD("THI")]APCD("HI"):9,APCD("HI")=APCD("THI"):10,1:11)

 E  S APCDCASE=$S(APCD("LOW")=APCD("THI"):12,1:13)

 Q

 ;

NUMBER ;

 S APCD("CODE")=APCD("LOW")-5 F  Q:APCD("LOW")]$O(^ICD9("BA",APCD("CODE")_" "))  S APCD("CODE")=APCD("CODE")-5

 S APCD("CODE")=$O(^ICD9("BA",APCD("CODE")_" ")) F  S APCD("NEWHI")=APCD("CODE"),APCD("CODE")=$O(^ICD9("BA",APCD("CODE"))) Q:APCD("CODE")=APCD("LOW")

 Q

 ;

LETTER ;

 S APCD("LET")=$E(APCD("LOW"))_" " F  S APCD("NEWHI")=$S($L(APCD("LET"))>2:APCD("LET"),1:APCD("LOW")),APCD("LET")=$O(^ICD9("BA",APCD("LET"))) Q:APCD("LET")=APCD("LOW")

 Q

EOJ ;

 K APCDCASE,APCDDONE,APCDNEXT,APCDONE,APCDVAL

 Q

 ;

APCDFQA5  ; IHS/CMI/LAB - MAINTAIN CODE RANGES IN TABLE ; 24 Jul 2012  5:04 PM

 +1       ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 +2       ;

 +3        IF 'APCDSUB

               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(APCDTABL)

               SET APCDTABL(APCD("LOW"))=APCD("HI")_U_APCDSYS

               GOTO X1

 +2        SET APCDDONE=0

 +3        SET APCDVAL=""

           FOR 

               SET APCDVAL=$ORDER(APCDTABL(APCDVAL))

               IF APCDVAL=""

                   QUIT 

               IF $PIECE(APCDTABL(APCDVAL),U,2)=APCDSYS

                   DO GETCASE

                   DO ADDPROC

                   IF APCDDONE

                       QUIT 

 +4        IF 'APCDDONE

               DO SETRANGE

 +5        KILL APCDDONE,APCDVAL,APCDCASE

X1         QUIT 

 +1       ;

ADDPROC   ; CASE SPECIFIC ADD PROCESSING

 +1        GOTO @("ADD"_APCDCASE)

ADD2      ;;

ADD3      ;;

ADD4      ;;

 +1        SET APCDTABL(APCD("LOW"))=APCDTABL(APCDVAL)

 +2        KILL APCDTABL(APCDVAL)

ADD6      ;;

ADD7      ;;

ADD9      ;;

ADD10     ;;

 +1        SET APCDDONE=1

 +2        QUIT 

ADD11     ;;

ADD12     ;;

 +1        SET APCD("LOW")=APCDVAL

ADD5      ;;

ADD8      ;;

 +1        KILL APCDTABL(APCDVAL)

 +2        QUIT 

ADD1      ;;

 +1        IF $ORDER(^ICD9("BA",APCD("HI")))=APCDVAL

               IF $EXTRACT(APCDVAL)=$EXTRACT(APCD("HI"))!(APCDVAL&APCD("HI"))

                   SET APCDTABL(APCD("LOW"))=APCDTABL(APCDVAL)

                   KILL APCDTABL(APCDVAL)

                   SET APCDDONE=1

 +2        QUIT 

ADD13     ;;

 +1        IF $ORDER(^ICD9("BA",APCDTABL(APCDVAL)))=APCD("LOW")

               IF $EXTRACT(APCDVAL)=$EXTRACT(APCD("LOW"))!(APCDVAL&APCD("LOW"))

                   SET APCD("LOW")=APCDVAL

                   KILL APCDTABL(APCDVAL)

 +2       ; continue

 +3        QUIT 

 +4       ;

SETRANGE  ;

 +1       ;;

SET1      ;;

SET5      ;;

SET8      ;;

SET11     ;;

SET12     ;;

SET13     ;;

 +1        SET APCDTABL(APCD("LOW"))=APCD("HI")_U_APCDSYS

 +2        QUIT 

 +3       ;

DEL       ; SECTION FOR DELETING CODES FROM TABLE

 +1        IF '$DATA(APCDTABL)

               GOTO X2

 +2        SET APCDDONE=0

 +3        SET APCDVAL=""

           FOR 

               SET APCDVAL=$ORDER(APCDTABL(APCDVAL))

               IF APCDVAL=""

                   QUIT 

               IF $PIECE(APCDTABL(APCDVAL),U,2)=APCDSYS

                   DO GETCASE

                   DO DELPROC

                   IF APCDDONE

                       QUIT 

X2         QUIT 

 +1       ;

DELPROC   ;CASE SPECIFIC DEL PROCESSING

 +1        GOTO @("DEL"_APCDCASE)

DEL2      ;;

 +1        IF APCD("HI")=APCDTABL(APCDVAL)

               KILL APCDTABL(APCDVAL)

 +2       IF '$TEST

               SET APCDTABL($ORDER(^ICD9("BA",APCD("HI"))))=APCDTABL(APCDVAL)_U_APCDSYS

               KILL APCDTABL(APCDVAL)

 +3        SET APCDDONE=1

 +4        QUIT 

 +5       ;

DEL3      ;;

DEL6      ;;

 +1        SET APCDTABL($ORDER(^ICD9("BA",APCD("HI"))))=APCDTABL(APCDVAL)_U_APCDSYS

           KILL APCDTABL(APCDVAL)

 +2        SET APCDDONE=1

 +3        QUIT 

 +4       ;

DEL4      ;;

DEL5      ;;

DEL7      ;;

DEL8      ;;

 +1        KILL APCDTABL(APCDVAL)

 +2        IF APCDCASE'=8

               IF APCDCASE'=5

                   SET APCDDONE=1

 +3        QUIT 

 +4       ;

DEL10     ;;

DEL11     ;;

DEL12     ;;

 +1        DO @$SELECT($EXTRACT(APCDTABL(APCDVAL))?1N:"NUMBER",1:"LETTER")

 +2        SET APCDTABL(APCDVAL)=APCD("NEWHI")_U_APCDSYS

 +3        IF APCDCASE=10

               SET APCDDONE=1

 +4        QUIT 

 +5       ;

DEL9      ;;

 +1        DO @$SELECT($EXTRACT(APCDTABL(APCDVAL))?1N:"NUMBER",1:"LETTER")

 +2        SET APCDTABL($ORDER(^ICD9("BA",APCD("HI"))))=APCDTABL(APCDVAL)_U_APCDSYS

 +3        SET APCDTABL(APCDVAL)=APCD("NEWHI")_U_APCDSYS

 +4        SET APCDDONE=1

 +5        QUIT 

 +6       ;

DEL1      ;;

DEL13     ;;

 +1        QUIT 

 +2       ;

GETCASE   ; SUBROUTINE TO DETERMINE APCDCASE # FROM INPUT CODE RANGE

 +1       ;_U_APCDSYS

           SET APCD("TLOW")=APCDVAL

           SET APCD("THI")=$PIECE(APCDTABL(APCDVAL),U,1)

 +2        IF APCD("TLOW")]APCD("LOW")

               DO CASEA

           IF APCD("LOW")=APCD("TLOW")

               DO CASEB

           IF APCD("LOW")]APCD("TLOW")

               DO CASEC

 +3        KILL APCD("TLOW"),APCD("THI")

 +4        QUIT 

 +5       ;

CASEA     ;

 +1        IF APCD("HI")]APCD("TLOW")

               SET APCDCASE=$SELECT(APCD("THI")]APCD("HI"):3,APCD("HI")=APCD("THI"):4,1:5)

 +2       IF '$TEST

               SET APCDCASE=$SELECT(APCD("TLOW")]APCD("HI"):1,1:2)

 +3        QUIT 

 +4       ;

CASEB     ;

 +1        SET APCDCASE=$SELECT(APCD("THI")]APCD("HI"):6,APCD("HI")=APCD("THI"):7,1:8)

 +2        QUIT 

 +3       ;

CASEC     ;

 +1        IF APCD("THI")]APCD("LOW")

               SET APCDCASE=$SELECT(APCD("THI")]APCD("HI"):9,APCD("HI")=APCD("THI"):10,1:11)

 +2       IF '$TEST

               SET APCDCASE=$SELECT(APCD("LOW")=APCD("THI"):12,1:13)

 +3        QUIT 

 +4       ;

NUMBER    ;

 +1        SET APCD("CODE")=APCD("LOW")-5

           FOR 

               IF APCD("LOW")]$ORDER(^ICD9("BA",APCD("CODE")_" "))

                   QUIT 

               SET APCD("CODE")=APCD("CODE")-5

 +2        SET APCD("CODE")=$ORDER(^ICD9("BA",APCD("CODE")_" "))

           FOR 

               SET APCD("NEWHI")=APCD("CODE")

               SET APCD("CODE")=$ORDER(^ICD9("BA",APCD("CODE")))

               IF APCD("CODE")=APCD("LOW")

                   QUIT 

 +3        QUIT 

 +4       ;

LETTER    ;

 +1        SET APCD("LET")=$EXTRACT(APCD("LOW"))_" "

           FOR 

               SET APCD("NEWHI")=$SELECT($LENGTH(APCD("LET"))>2:APCD("LET"),1:APCD("LOW"))

               SET APCD("LET")=$ORDER(^ICD9("BA",APCD("LET")))

               IF APCD("LET")=APCD("LOW")

                   QUIT 

 +2        QUIT 

EOJ       ;

 +1        KILL APCDCASE,APCDDONE,APCDNEXT,APCDONE,APCDVAL

 +2        QUIT 

 +3       ;