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

APCHTAXN.m

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