APCLAUD7 ; IHS/CMI/LAB - CODE RANGES IN TABLE ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
I 'APCLSUB D ADD I 1
E D DEL
D EOJ
Q
;
ADD ; SECTION FOR ADDING CODES TO TABLE
I '$D(APCLTABL) S APCLTABL(APCL("LOW"))=APCL("HI")_U_APCLSYS G X1
S APCLDONE=0
S APCLVAL="" F S APCLVAL=$O(APCLTABL(APCLVAL)) Q:APCLVAL="" I $P(APCLTABL(APCLVAL),U,2)=APCLSYS D GETCASE,ADDPROC Q:APCLDONE
D:'APCLDONE SETRANGE
K APCLDONE,APCLVAL,APCLCASE
X1 Q
;
ADDPROC ; CASE SPECIFIC ADD PROCESSING
G @("ADD"_APCLCASE)
ADD2 ;;
ADD3 ;;
ADD4 ;;
S APCLTABL(APCL("LOW"))=APCLTABL(APCLVAL)
K APCLTABL(APCLVAL)
ADD6 ;;
ADD7 ;;
ADD9 ;;
ADD10 ;;
S APCLDONE=1
Q
ADD11 ;;
ADD12 ;;
S APCL("LOW")=APCLVAL
ADD5 ;;
ADD8 ;;
K APCLTABL(APCLVAL)
Q
ADD1 ;;
I $O(^ICD9("BA",APCL("HI")))=APCLVAL,$E(APCLVAL)=$E(APCL("HI"))!(APCLVAL&APCL("HI")) S APCLTABL(APCL("LOW"))=APCLTABL(APCLVAL) K APCLTABL(APCLVAL) S APCLDONE=1
Q
ADD13 ;;
I $O(^ICD9("BA",APCLTABL(APCLVAL)))=APCL("LOW"),$E(APCLVAL)=$E(APCL("LOW"))!(APCLVAL&APCL("LOW")) S APCL("LOW")=APCLVAL K APCLTABL(APCLVAL)
; continue
Q
;
SETRANGE ;
;;
SET1 ;;
SET5 ;;
SET8 ;;
SET11 ;;
SET12 ;;
SET13 ;;
S APCLTABL(APCL("LOW"))=APCL("HI")_U_APCLSYS
Q
;
DEL ; SECTION FOR DELETING CODES FROM TABLE
I '$D(APCLTABL) G X2
S APCLDONE=0
S APCLVAL="" F S APCLVAL=$O(APCLTABL(APCLVAL)) Q:APCLVAL="" I $P(APCLTABL(APCLVAL),U,2)=APCLSYS D GETCASE,DELPROC Q:APCLDONE
X2 Q
;
DELPROC ;CASE SPECIFIC DEL PROCESSING
G @("DEL"_APCLCASE)
DEL2 ;;
I APCL("HI")=APCLTABL(APCLVAL) K APCLTABL(APCLVAL)
E S APCLTABL($O(^ICD9("BA",APCL("HI"))))=APCLTABL(APCLVAL)_U_APCLSYS K APCLTABL(APCLVAL)
S APCLDONE=1
Q
;
DEL3 ;;
DEL6 ;;
S APCLTABL($O(^ICD9("BA",APCL("HI"))))=APCLTABL(APCLVAL)_U_APCLSYS K APCLTABL(APCLVAL)
S APCLDONE=1
Q
;
DEL4 ;;
DEL5 ;;
DEL7 ;;
DEL8 ;;
K APCLTABL(APCLVAL)
I APCLCASE'=8,APCLCASE'=5 S APCLDONE=1
Q
;
DEL10 ;;
DEL11 ;;
DEL12 ;;
D @$S($E(APCLTABL(APCLVAL))?1N:"NUMBER",1:"LETTER")
S APCLTABL(APCLVAL)=APCL("NEWHI")_U_APCLSYS
I APCLCASE=10 S APCLDONE=1
Q
;
DEL9 ;;
D @$S($E(APCLTABL(APCLVAL))?1N:"NUMBER",1:"LETTER")
S APCLTABL($O(^ICD9("BA",APCL("HI"))))=APCLTABL(APCLVAL)_U_APCLSYS
S APCLTABL(APCLVAL)=APCL("NEWHI")_U_APCLSYS
S APCLDONE=1
Q
;
DEL1 ;;
DEL13 ;;
Q
;
GETCASE ; SUBROUTINE TO DETERMINE APCLCASE # FROM INPUT CODE RANGE
S APCL("TLOW")=APCLVAL,APCL("THI")=$P(APCLTABL(APCLVAL),U,1) ;_U_APCLSYS
D CASEA:APCL("TLOW")]APCL("LOW"),CASEB:APCL("LOW")=APCL("TLOW"),CASEC:APCL("LOW")]APCL("TLOW")
K APCL("TLOW"),APCL("THI")
Q
;
CASEA ;
I APCL("HI")]APCL("TLOW") S APCLCASE=$S(APCL("THI")]APCL("HI"):3,APCL("HI")=APCL("THI"):4,1:5)
E S APCLCASE=$S(APCL("TLOW")]APCL("HI"):1,1:2)
Q
;
CASEB ;
S APCLCASE=$S(APCL("THI")]APCL("HI"):6,APCL("HI")=APCL("THI"):7,1:8)
Q
;
CASEC ;
I APCL("THI")]APCL("LOW") S APCLCASE=$S(APCL("THI")]APCL("HI"):9,APCL("HI")=APCL("THI"):10,1:11)
E S APCLCASE=$S(APCL("LOW")=APCL("THI"):12,1:13)
Q
;
NUMBER ;
S APCL("CODE")=APCL("LOW")-5 F Q:APCL("LOW")]$O(^ICD9("BA",APCL("CODE")_" ")) S APCL("CODE")=APCL("CODE")-5
S APCL("CODE")=$O(^ICD9("BA",APCL("CODE")_" ")) F S APCL("NEWHI")=APCL("CODE"),APCL("CODE")=$O(^ICD9("BA",APCL("CODE"))) Q:APCL("CODE")=APCL("LOW")
Q
;
LETTER ;
S APCL("LET")=$E(APCL("LOW"))_" " F S APCL("NEWHI")=$S($L(APCL("LET"))>2:APCL("LET"),1:APCL("LOW")),APCL("LET")=$O(^ICD9("BA",APCL("LET"))) Q:APCL("LET")=APCL("LOW")
Q
EOJ ;
K APCLCASE,APCLDONE,APCLNEXT,APCLONE,APCLVAL
Q
;
APCLAUD7 ; IHS/CMI/LAB - CODE RANGES IN TABLE ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 IF 'APCLSUB
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(APCLTABL)
SET APCLTABL(APCL("LOW"))=APCL("HI")_U_APCLSYS
GOTO X1
+2 SET APCLDONE=0
+3 SET APCLVAL=""
FOR
SET APCLVAL=$ORDER(APCLTABL(APCLVAL))
IF APCLVAL=""
QUIT
IF $PIECE(APCLTABL(APCLVAL),U,2)=APCLSYS
DO GETCASE
DO ADDPROC
IF APCLDONE
QUIT
+4 IF 'APCLDONE
DO SETRANGE
+5 KILL APCLDONE,APCLVAL,APCLCASE
X1 QUIT
+1 ;
ADDPROC ; CASE SPECIFIC ADD PROCESSING
+1 GOTO @("ADD"_APCLCASE)
ADD2 ;;
ADD3 ;;
ADD4 ;;
+1 SET APCLTABL(APCL("LOW"))=APCLTABL(APCLVAL)
+2 KILL APCLTABL(APCLVAL)
ADD6 ;;
ADD7 ;;
ADD9 ;;
ADD10 ;;
+1 SET APCLDONE=1
+2 QUIT
ADD11 ;;
ADD12 ;;
+1 SET APCL("LOW")=APCLVAL
ADD5 ;;
ADD8 ;;
+1 KILL APCLTABL(APCLVAL)
+2 QUIT
ADD1 ;;
+1 IF $ORDER(^ICD9("BA",APCL("HI")))=APCLVAL
IF $EXTRACT(APCLVAL)=$EXTRACT(APCL("HI"))!(APCLVAL&APCL("HI"))
SET APCLTABL(APCL("LOW"))=APCLTABL(APCLVAL)
KILL APCLTABL(APCLVAL)
SET APCLDONE=1
+2 QUIT
ADD13 ;;
+1 IF $ORDER(^ICD9("BA",APCLTABL(APCLVAL)))=APCL("LOW")
IF $EXTRACT(APCLVAL)=$EXTRACT(APCL("LOW"))!(APCLVAL&APCL("LOW"))
SET APCL("LOW")=APCLVAL
KILL APCLTABL(APCLVAL)
+2 ; continue
+3 QUIT
+4 ;
SETRANGE ;
+1 ;;
SET1 ;;
SET5 ;;
SET8 ;;
SET11 ;;
SET12 ;;
SET13 ;;
+1 SET APCLTABL(APCL("LOW"))=APCL("HI")_U_APCLSYS
+2 QUIT
+3 ;
DEL ; SECTION FOR DELETING CODES FROM TABLE
+1 IF '$DATA(APCLTABL)
GOTO X2
+2 SET APCLDONE=0
+3 SET APCLVAL=""
FOR
SET APCLVAL=$ORDER(APCLTABL(APCLVAL))
IF APCLVAL=""
QUIT
IF $PIECE(APCLTABL(APCLVAL),U,2)=APCLSYS
DO GETCASE
DO DELPROC
IF APCLDONE
QUIT
X2 QUIT
+1 ;
DELPROC ;CASE SPECIFIC DEL PROCESSING
+1 GOTO @("DEL"_APCLCASE)
DEL2 ;;
+1 IF APCL("HI")=APCLTABL(APCLVAL)
KILL APCLTABL(APCLVAL)
+2 IF '$TEST
SET APCLTABL($ORDER(^ICD9("BA",APCL("HI"))))=APCLTABL(APCLVAL)_U_APCLSYS
KILL APCLTABL(APCLVAL)
+3 SET APCLDONE=1
+4 QUIT
+5 ;
DEL3 ;;
DEL6 ;;
+1 SET APCLTABL($ORDER(^ICD9("BA",APCL("HI"))))=APCLTABL(APCLVAL)_U_APCLSYS
KILL APCLTABL(APCLVAL)
+2 SET APCLDONE=1
+3 QUIT
+4 ;
DEL4 ;;
DEL5 ;;
DEL7 ;;
DEL8 ;;
+1 KILL APCLTABL(APCLVAL)
+2 IF APCLCASE'=8
IF APCLCASE'=5
SET APCLDONE=1
+3 QUIT
+4 ;
DEL10 ;;
DEL11 ;;
DEL12 ;;
+1 DO @$SELECT($EXTRACT(APCLTABL(APCLVAL))?1N:"NUMBER",1:"LETTER")
+2 SET APCLTABL(APCLVAL)=APCL("NEWHI")_U_APCLSYS
+3 IF APCLCASE=10
SET APCLDONE=1
+4 QUIT
+5 ;
DEL9 ;;
+1 DO @$SELECT($EXTRACT(APCLTABL(APCLVAL))?1N:"NUMBER",1:"LETTER")
+2 SET APCLTABL($ORDER(^ICD9("BA",APCL("HI"))))=APCLTABL(APCLVAL)_U_APCLSYS
+3 SET APCLTABL(APCLVAL)=APCL("NEWHI")_U_APCLSYS
+4 SET APCLDONE=1
+5 QUIT
+6 ;
DEL1 ;;
DEL13 ;;
+1 QUIT
+2 ;
GETCASE ; SUBROUTINE TO DETERMINE APCLCASE # FROM INPUT CODE RANGE
+1 ;_U_APCLSYS
SET APCL("TLOW")=APCLVAL
SET APCL("THI")=$PIECE(APCLTABL(APCLVAL),U,1)
+2 IF APCL("TLOW")]APCL("LOW")
DO CASEA
IF APCL("LOW")=APCL("TLOW")
DO CASEB
IF APCL("LOW")]APCL("TLOW")
DO CASEC
+3 KILL APCL("TLOW"),APCL("THI")
+4 QUIT
+5 ;
CASEA ;
+1 IF APCL("HI")]APCL("TLOW")
SET APCLCASE=$SELECT(APCL("THI")]APCL("HI"):3,APCL("HI")=APCL("THI"):4,1:5)
+2 IF '$TEST
SET APCLCASE=$SELECT(APCL("TLOW")]APCL("HI"):1,1:2)
+3 QUIT
+4 ;
CASEB ;
+1 SET APCLCASE=$SELECT(APCL("THI")]APCL("HI"):6,APCL("HI")=APCL("THI"):7,1:8)
+2 QUIT
+3 ;
CASEC ;
+1 IF APCL("THI")]APCL("LOW")
SET APCLCASE=$SELECT(APCL("THI")]APCL("HI"):9,APCL("HI")=APCL("THI"):10,1:11)
+2 IF '$TEST
SET APCLCASE=$SELECT(APCL("LOW")=APCL("THI"):12,1:13)
+3 QUIT
+4 ;
NUMBER ;
+1 SET APCL("CODE")=APCL("LOW")-5
FOR
IF APCL("LOW")]$ORDER(^ICD9("BA",APCL("CODE")_" "))
QUIT
SET APCL("CODE")=APCL("CODE")-5
+2 SET APCL("CODE")=$ORDER(^ICD9("BA",APCL("CODE")_" "))
FOR
SET APCL("NEWHI")=APCL("CODE")
SET APCL("CODE")=$ORDER(^ICD9("BA",APCL("CODE")))
IF APCL("CODE")=APCL("LOW")
QUIT
+3 QUIT
+4 ;
LETTER ;
+1 SET APCL("LET")=$EXTRACT(APCL("LOW"))_" "
FOR
SET APCL("NEWHI")=$SELECT($LENGTH(APCL("LET"))>2:APCL("LET"),1:APCL("LOW"))
SET APCL("LET")=$ORDER(^ICD9("BA",APCL("LET")))
IF APCL("LET")=APCL("LOW")
QUIT
+2 QUIT
EOJ ;
+1 KILL APCLCASE,APCLDONE,APCLNEXT,APCLONE,APCLVAL
+2 QUIT
+3 ;
