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