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

BDMCOD1.m

Go to the documentation of this file. 
  1. BDMCOD1 ; IHS/CMI/LAB - CODE RANGES IN TABLE ;
  1.  ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
  1.  ;
  1.  I 'BDMSUB 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(BDMTBLE) S BDMTBLE(BDM("LOW"))=BDM("HI") G X1
  1.  S BDMDONE=0
  1.  S BDMVAL="" F  S BDMVAL=$O(BDMTBLE(BDMVAL)) Q:BDMVAL=""   D GETCASE,ADDPROC Q:BDMDONE
  1.  D:'BDMDONE SETRANGE
  1.  K BDMDONE,BDMVAL,BDMCASE
  1. X1 Q
  1.  ;
  1. ADDPROC ; CASE SPECIFIC ADD PROCESSING
  1.  G @("ADD"_BDMCASE)
  1. ADD2 ;;
  1. ADD3 ;;
  1. ADD4 ;;
  1.  S BDMTBLE(BDM("LOW"))=BDMTBLE(BDMVAL)
  1.  K BDMTBLE(BDMVAL)
  1. ADD6 ;;
  1. ADD7 ;;
  1. ADD9 ;;
  1. ADD10 ;;
  1.  S BDMDONE=1
  1.  Q
  1. ADD11 ;;
  1. ADD12 ;;
  1.  S BDM("LOW")=BDMVAL
  1. ADD5 ;;
  1. ADD8 ;;
  1.  K BDMTBLE(BDMVAL)
  1.  Q
  1. ADD1 ;;
  1.  I $O(^ICD9("BA",BDM("HI")))=BDMVAL,$E(BDMVAL)=$E(BDM("HI"))!(BDMVAL&BDM("HI")) S BDMTBLE(BDM("LOW"))=BDMTBLE(BDMVAL) K BDMTBLE(BDMVAL) S BDMDONE=1
  1.  Q
  1. ADD13 ;;
  1.  I $O(^ICD9("BA",BDMTBLE(BDMVAL)))=BDM("LOW"),$E(BDMVAL)=$E(BDM("LOW"))!(BDMVAL&BDM("LOW")) S BDM("LOW")=BDMVAL K BDMTBLE(BDMVAL)
  1.  ; continue
  1.  Q
  1.  ;
  1. SETRANGE ;
  1.  ;;
  1. SET1 ;;
  1. SET5 ;;
  1. SET8 ;;
  1. SET11 ;;
  1. SET12 ;;
  1. SET13 ;;
  1.  S BDMTBLE(BDM("LOW"))=BDM("HI")
  1.  Q
  1.  ;
  1. DEL ; SECTION FOR DELETING CODES FROM TABLE
  1.  I '$D(BDMTBLE) G X2
  1.  S BDMDONE=0
  1.  S BDMVAL="" F  S BDMVAL=$O(BDMTBLE(BDMVAL)) Q:BDMVAL=""  D GETCASE,DELPROC Q:BDMDONE
  1. X2 Q
  1.  ;
  1. DELPROC ;CASE SPECIFIC DEL PROCESSING
  1.  G @("DEL"_BDMCASE)
  1. DEL2 ;;
  1.  I BDM("HI")=BDMTBLE(BDMVAL) K BDMTBLE(BDMVAL)
  1.  E  S BDMTBLE($O(^ICD9("BA",BDM("HI"))))=BDMTBLE(BDMVAL) K BDMTBLE(BDMVAL)
  1.  S BDMDONE=1
  1.  Q
  1.  ;
  1. DEL3 ;;
  1. DEL6 ;;
  1.  S BDMTBLE($O(^ICD9("BA",BDM("HI"))))=BDMTBLE(BDMVAL) K BDMTBLE(BDMVAL)
  1.  S BDMDONE=1
  1.  Q
  1.  ;
  1. DEL4 ;;
  1. DEL5 ;;
  1. DEL7 ;;
  1. DEL8 ;;
  1.  K BDMTBLE(BDMVAL)
  1.  I BDMCASE'=8,BDMCASE'=5 S BDMDONE=1
  1.  Q
  1.  ;
  1. DEL10 ;;
  1. DEL11 ;;
  1. DEL12 ;;
  1.  D @$S($E(BDMTBLE(BDMVAL))?1N:"NUMBER",1:"LETTER")
  1.  S BDMTBLE(BDMVAL)=BDM("NEWHI")
  1.  I BDMCASE=10 S BDMDONE=1
  1.  Q
  1.  ;
  1. DEL9 ;;
  1.  D @$S($E(BDMTBLE(BDMVAL))?1N:"NUMBER",1:"LETTER")
  1.  S BDMTBLE($O(^ICD9("BA",BDM("HI"))))=BDMTBLE(BDMVAL)
  1.  S BDMTBLE(BDMVAL)=BDM("NEWHI")
  1.  S BDMDONE=1
  1.  Q
  1.  ;
  1. DEL1 ;;
  1. DEL13 ;;
  1.  Q
  1.  ;
  1. GETCASE ; SUBROUTINE TO DETERMINE BDMCASE # FROM INPUT CODE RANGE
  1.  S BDM("TLOW")=BDMVAL,BDM("THI")=BDMTBLE(BDMVAL)
  1.  D CASEA:BDM("TLOW")]BDM("LOW"),CASEB:BDM("LOW")=BDM("TLOW"),CASEC:BDM("LOW")]BDM("TLOW")
  1.  K BDM("TLOW"),BDM("THI")
  1.  Q
  1.  ;
  1. CASEA ;
  1.  I BDM("HI")]BDM("TLOW") S BDMCASE=$S(BDM("THI")]BDM("HI"):3,BDM("HI")=BDM("THI"):4,1:5)
  1.  E  S BDMCASE=$S(BDM("TLOW")]BDM("HI"):1,1:2)
  1.  Q
  1.  ;
  1. CASEB ;
  1.  S BDMCASE=$S(BDM("THI")]BDM("HI"):6,BDM("HI")=BDM("THI"):7,1:8)
  1.  Q
  1.  ;
  1. CASEC ;
  1.  I BDM("THI")]BDM("LOW") S BDMCASE=$S(BDM("THI")]BDM("HI"):9,BDM("HI")=BDM("THI"):10,1:11)
  1.  E  S BDMCASE=$S(BDM("LOW")=BDM("THI"):12,1:13)
  1.  Q
  1.  ;
  1. NUMBER ;
  1.  S BDM("CODE")=BDM("LOW")-5 F  Q:BDM("LOW")]$O(^ICD9("BA",BDM("CODE")_" "))  S BDM("CODE")=BDM("CODE")-5
  1.  S BDM("CODE")=$O(^ICD9("BA",BDM("CODE")_" ")) F  S BDM("NEWHI")=BDM("CODE"),BDM("CODE")=$O(^ICD9("BA",BDM("CODE"))) Q:BDM("CODE")=BDM("LOW")
  1.  Q
  1.  ;
  1. LETTER ;
  1.  S BDM("LET")=$E(BDM("LOW"))_" " F  S BDM("NEWHI")=$S($L(BDM("LET"))>2:BDM("LET"),1:BDM("LOW")),BDM("LET")=$O(^ICD9("BA",BDM("LET"))) Q:BDM("LET")=BDM("LOW")
  1.  Q
  1. EOJ ;
  1.  K BDMCASE,BDMDONE,BDMNEXT,BDMONE,BDMVAL
  1.  Q
  1.  ;