APCDFOA5 ; 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(^ICD0("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(^ICD0("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(^ICD0("BA",APCD("HI"))))=APCDTABL(APCDVAL)_U_APCDSYS K APCDTABL(APCDVAL)
S APCDDONE=1
Q
;
DEL3 ;;
DEL6 ;;
S APCDTABL($O(^ICD0("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(^ICD0("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(^ICD0("BA",APCD("CODE")_" ")) S APCD("CODE")=APCD("CODE")-5
S APCD("CODE")=$O(^ICD0("BA",APCD("CODE")_" ")) F S APCD("NEWHI")=APCD("CODE"),APCD("CODE")=$O(^ICD0("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(^ICD0("BA",APCD("LET"))) Q:APCD("LET")=APCD("LOW")
Q
EOJ ;
K APCDCASE,APCDDONE,APCDNEXT,APCDONE,APCDVAL
Q
;
APCDFOA5 ; 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(^ICD0("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(^ICD0("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(^ICD0("BA",APCD("HI"))))=APCDTABL(APCDVAL)_U_APCDSYS
KILL APCDTABL(APCDVAL)
+3 SET APCDDONE=1
+4 QUIT
+5 ;
DEL3 ;;
DEL6 ;;
+1 SET APCDTABL($ORDER(^ICD0("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(^ICD0("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(^ICD0("BA",APCD("CODE")_" "))
QUIT
SET APCD("CODE")=APCD("CODE")-5
+2 SET APCD("CODE")=$ORDER(^ICD0("BA",APCD("CODE")_" "))
FOR
SET APCD("NEWHI")=APCD("CODE")
SET APCD("CODE")=$ORDER(^ICD0("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(^ICD0("BA",APCD("LET")))
IF APCD("LET")=APCD("LOW")
QUIT
+2 QUIT
EOJ ;
+1 KILL APCDCASE,APCDDONE,APCDNEXT,APCDONE,APCDVAL
+2 QUIT
+3 ;
