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

ATXCODE1.m

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