Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLTAXJ

APCLTAXJ.m

Go to the documentation of this file. 
  1. APCLTAXJ ; IHS/CMI/LAB - CODE RANGES IN TABLE ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1.  I 'APCLSUB D ADD I 1
  1.  E  D DEL
  1.  D EOJ
  1.  Q
  1.  ;
  1. ADD ; SECTION FOR ADDING CODES TO TABLE
  1.  I '$D(APCLTBLE) S APCLTBLE(APCL("LOW"))=APCL("HI") G X1
  1.  S APCLDONE=0
  1.  S APCLVAL="" F  S APCLVAL=$O(APCLTBLE(APCLVAL)) Q:APCLVAL=""   D GETCASE,ADDPROC Q:APCLDONE
  1.  D:'APCLDONE SETRANGE
  1.  K APCLDONE,APCLVAL,APCLCASE
  1. X1 Q
  1.  ;
  1. ADDPROC ; CASE SPECIFIC ADD PROCESSING
  1.  G @("ADD"_APCLCASE)
  1. ADD2 ;;
  1. ADD3 ;;
  1. ADD4 ;;
  1.  S APCLTBLE(APCL("LOW"))=APCLTBLE(APCLVAL)
  1.  K APCLTBLE(APCLVAL)
  1. ADD6 ;;
  1. ADD7 ;;
  1. ADD9 ;;
  1. ADD10 ;;
  1.  S APCLDONE=1
  1.  Q
  1. ADD11 ;;
  1. ADD12 ;;
  1.  S APCL("LOW")=APCLVAL
  1. ADD5 ;;
  1. ADD8 ;;
  1.  K APCLTBLE(APCLVAL)
  1.  Q
  1. ADD1 ;;
  1.  I $O(^ICD0("BA",APCL("HI")))=APCLVAL,$E(APCLVAL)=$E(APCL("HI"))!(APCLVAL&APCL("HI")) S APCLTBLE(APCL("LOW"))=APCLTBLE(APCLVAL) K APCLTBLE(APCLVAL) S APCLDONE=1
  1.  Q
  1. ADD13 ;;
  1.  I $O(^ICD0("BA",APCLTBLE(APCLVAL)))=APCL("LOW"),$E(APCLVAL)=$E(APCL("LOW"))!(APCLVAL&APCL("LOW")) S APCL("LOW")=APCLVAL K APCLTBLE(APCLVAL)
  1.  ; continue
  1.  Q
  1.  ;
  1. SETRANGE ;
  1.  ;;
  1. SET1 ;;
  1. SET5 ;;
  1. SET8 ;;
  1. SET11 ;;
  1. SET12 ;;
  1. SET13 ;;
  1.  S APCLTBLE(APCL("LOW"))=APCL("HI")
  1.  Q
  1.  ;
  1. DEL ; SECTION FOR DELETING CODES FROM TABLE
  1.  I '$D(APCLTBLE) G X2
  1.  S APCLDONE=0
  1.  S APCLVAL="" F  S APCLVAL=$O(APCLTBLE(APCLVAL)) Q:APCLVAL=""  D GETCASE,DELPROC Q:APCLDONE
  1. X2 Q
  1.  ;
  1. DELPROC ;CASE SPECIFIC DEL PROCESSING
  1.  G @("DEL"_APCLCASE)
  1. DEL2 ;;
  1.  I APCL("HI")=APCLTBLE(APCLVAL) K APCLTBLE(APCLVAL)
  1.  E  S APCLTBLE($O(^ICD0("BA",APCL("HI"))))=APCLTBLE(APCLVAL) K APCLTBLE(APCLVAL)
  1.  S APCLDONE=1
  1.  Q
  1.  ;
  1. DEL3 ;;
  1. DEL6 ;;
  1.  S APCLTBLE($O(^ICD0("BA",APCL("HI"))))=APCLTBLE(APCLVAL) K APCLTBLE(APCLVAL)
  1.  S APCLDONE=1
  1.  Q
  1.  ;
  1. DEL4 ;;
  1. DEL5 ;;
  1. DEL7 ;;
  1. DEL8 ;;
  1.  K APCLTBLE(APCLVAL)
  1.  I APCLCASE'=8,APCLCASE'=5 S APCLDONE=1
  1.  Q
  1.  ;
  1. DEL10 ;;
  1. DEL11 ;;
  1. DEL12 ;;
  1.  D @$S($E(APCLTBLE(APCLVAL))?1N:"NUMBER",1:"LETTER")
  1.  S APCLTBLE(APCLVAL)=APCL("NEWHI")
  1.  I APCLCASE=10 S APCLDONE=1
  1.  Q
  1.  ;
  1. DEL9 ;;
  1.  D @$S($E(APCLTBLE(APCLVAL))?1N:"NUMBER",1:"LETTER")
  1.  S APCLTBLE($O(^ICD0("BA",APCL("HI"))))=APCLTBLE(APCLVAL)
  1.  S APCLTBLE(APCLVAL)=APCL("NEWHI")
  1.  S APCLDONE=1
  1.  Q
  1.  ;
  1. DEL1 ;;
  1. DEL13 ;;
  1.  Q
  1.  ;
  1. GETCASE ; SUBROUTINE TO DETERMINE APCLCASE # FROM INPUT CODE RANGE
  1.  S APCL("TLOW")=APCLVAL,APCL("THI")=APCLTBLE(APCLVAL)
  1.  D CASEA:APCL("TLOW")]APCL("LOW"),CASEB:APCL("LOW")=APCL("TLOW"),CASEC:APCL("LOW")]APCL("TLOW")
  1.  K APCL("TLOW"),APCL("THI")
  1.  Q
  1.  ;
  1. CASEA ;
  1.  I APCL("HI")]APCL("TLOW") S APCLCASE=$S(APCL("THI")]APCL("HI"):3,APCL("HI")=APCL("THI"):4,1:5)
  1.  E  S APCLCASE=$S(APCL("TLOW")]APCL("HI"):1,1:2)
  1.  Q
  1.  ;
  1. CASEB ;
  1.  S APCLCASE=$S(APCL("THI")]APCL("HI"):6,APCL("HI")=APCL("THI"):7,1:8)
  1.  Q
  1.  ;
  1. CASEC ;
  1.  I APCL("THI")]APCL("LOW") S APCLCASE=$S(APCL("THI")]APCL("HI"):9,APCL("HI")=APCL("THI"):10,1:11)
  1.  E  S APCLCASE=$S(APCL("LOW")=APCL("THI"):12,1:13)
  1.  Q
  1.  ;
  1. NUMBER ;
  1.  S APCL("CODE")=APCL("LOW")-5 F  Q:APCL("LOW")]$O(^ICD0("BA",APCL("CODE")_" "))  S APCL("CODE")=APCL("CODE")-5
  1.  S APCL("CODE")=$O(^ICD0("BA",APCL("CODE")_" ")) F  S APCL("NEWHI")=APCL("CODE"),APCL("CODE")=$O(^ICD0("BA",APCL("CODE"))) Q:APCL("CODE")=APCL("LOW")
  1.  Q
  1.  ;
  1. LETTER ;
  1.  S APCL("LET")=$E(APCL("LOW"))_" " F  S APCL("NEWHI")=$S($L(APCL("LET"))>2:APCL("LET"),1:APCL("LOW")),APCL("LET")=$O(^ICD0("BA",APCL("LET"))) Q:APCL("LET")=APCL("LOW")
  1.  Q
  1. EOJ ;
  1.  K APCLCASE,APCLDONE,APCLNEXT,APCLONE,APCLVAL
  1.  Q
  1.  ;