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

ORCRC.m

Go to the documentation of this file. 
  1. ORCRC ;SLC/JM - standard CRC routine ;3/1/06
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**245**;Dec 17, 1997;Build 2
  1.  Q
  1.  ;
  1.  ; CRC4ARRY entry point returns same CRC as the CRCForStrings routine in ORFn
  1.  ; in the Delphi code used by CPRS.  Value returned is in HEX format
  1.  ;
  1.  ; Delphi logic:
  1.  ;  
  1.  ;  Result:=$FFFFFFFF;
  1.  ;  for i := 0 to AStringList.Count - 1 do
  1.  ;    for j := 1 to Length(AStringList[i]) do
  1.  ;      Result:=((Result shr 8) and $00FFFFFF) xor
  1.  ;        CRC32_TABLE[(Result xor Ord(AStringList[i][j])) and $000000FF];
  1.  ;
  1. CRC4ARRY(ARRAY) ; Returns a CRC for an array of strings
  1.  N RESULT,LINE,IDX,I,CHR,MASK1,MASK2,TBLIDX,TBLVALUE,BINTBL,HEXTBL
  1.  S BINTBL=".0000.0001.0010.0011.0100.0101.0110.0111.1000.1001.1010.1011.1100.1101.1110.1111."
  1.  S HEXTBL="0123456789ABCDEF"
  1.  S MASK1=$$HEX2BIN("FFFFFF")
  1.  S MASK2=$$HEX2BIN("FF")
  1.  S RESULT=$$HEX2BIN("FFFFFFFF"),IDX=""
  1.  F  S IDX=$O(ARRAY(IDX)) Q:IDX=""  D
  1.  . S LINE=ARRAY(IDX),LEN=$L(LINE)
  1.  . F I=1:1:LEN D
  1.  . . S CHR=$A($E(LINE,I)),CHR=$$INT2HEX(CHR,2),CHR=$$HEX2BIN(CHR)
  1.  . . S TBLIDX=$$AND(RESULT,MASK2),TBLIDX=$$XOR(TBLIDX,CHR)
  1.  . . S TBLIDX=$$BIN2HEX(TBLIDX),TBLIDX=$$HEX2INT(TBLIDX)
  1.  . . I TBLIDX'<0,TBLIDX<256 D  I 1
  1.  . . . S TBLVALUE=$$CRCTABLE(TBLIDX),TBLVALUE=$$HEX2BIN(TBLVALUE)
  1.  . . E  S TBLVALUE=0
  1.  . . S RESULT=$$SHR(RESULT,8),RESULT=$$AND(RESULT,MASK1)
  1.  . . S RESULT=$$XOR(RESULT,TBLVALUE)
  1.  S RESULT=$$BIN2HEX(RESULT)
  1.  F  Q:$L(RESULT)'<8  S RESULT="0"_RESULT
  1.  Q RESULT
  1.  ;
  1.  ; Supporting routines needed by CRC4ARRY
  1.  ;
  1. XOR(BIN1,BIN2) ; Exclusive OR of 2 binary numbers - returns binary value
  1.  N BIN,IDX1,IDX2,LEN,LEN1,LEN2,IDX,BIT,BITS
  1.  S BIN="",LEN1=$L(BIN1),LEN2=$L(BIN2),LEN=LEN1 I LEN2<LEN S LEN=LEN2
  1.  F IDX=1:1:LEN  D
  1.  . S BIT="0",BITS=$E(BIN1,LEN1)_$E(BIN2,LEN2)
  1.  . I (BITS="10")!(BITS="01") S BIT="1"
  1.  . S BIN=BIT_BIN,LEN1=LEN1-1,LEN2=LEN2-1
  1.  I LEN1>0 S BIN=$E(BIN1,1,LEN1)_BIN I 1
  1.  E  I LEN2>0 S BIN=$E(BIN2,1,LEN2)_BIN
  1.  Q BIN
  1. AND(BIN1,BIN2) ; AND of 2 binary numbers - returns binary value
  1.  N BIN,IDX1,IDX2,LEN,LEN1,LEN2,IDX,BIT
  1.  S BIN="",LEN1=$L(BIN1),LEN2=$L(BIN2),LEN=LEN1 I LEN2<LEN S LEN=LEN2
  1.  F IDX=1:1:LEN  D
  1.  . S BIT="0"
  1.  . I $E(BIN1,LEN1)="1",$E(BIN2,LEN2)="1" S BIT="1"
  1.  . S BIN=BIT_BIN,LEN1=LEN1-1,LEN2=LEN2-1
  1.  Q BIN
  1. SHR(BIN,SHIFT) ; Shift right SHIFT bits of binary number - returns binary value
  1.  I $L(BIN)'>SHIFT S BIN=""
  1.  E  S BIN=$E(BIN,1,$L(BIN)-SHIFT)
  1.  Q BIN
  1. HEX2BIN(HEX) ; Converts hex to binary - assumes valid input
  1.  N LEN,BIN,IDX,OFFSET
  1.  S LEN=$L(HEX),BIN=""
  1.  F IDX=1:1:LEN D
  1.  . S OFFSET=$F(HEXTBL,$E(HEX,IDX))-2,OFFSET=(OFFSET*5)+2
  1.  . S BIN=BIN_$E(BINTBL,OFFSET,OFFSET+3)
  1.  Q BIN
  1. BIN2HEX(BIN) ; Converts binary to hex - assumes valid input
  1.  N LEN,HEX,IDX,CHAR,DIGIT
  1.  S LEN=$L(BIN)
  1.  I LEN#4'=0 S BIN=$E("000",1,4-LEN#4)_BIN
  1.  S LEN=$L(BIN)/4,HEX=""
  1.  F IDX=1:1:LEN D
  1.  . S DIGIT="."_$E(BIN,1,4)_".",BIN=$E(BIN,5,9999)
  1.  . S CHAR=($F(BINTBL,DIGIT)-7)/5,HEX=HEX_$E(HEXTBL,CHAR+1)
  1.  Q HEX
  1. INT2HEX(INT,SIZE) ; Converts int to hex
  1.  N HEX,DIGIT S HEX=""
  1.  I $G(SIZE)<1 S SIZE=1
  1.  F  Q:INT'>0  D
  1.  . S DIGIT=INT#16,DIGIT=$E(HEXTBL,DIGIT+1)
  1.  . S HEX=DIGIT_HEX,INT=INT\16
  1.  F  Q:$L(HEX)'<SIZE  S HEX="0"_HEX
  1.  Q HEX
  1. HEX2INT(HEX) ; Converts hex to integer
  1.  N INT,IDX,DIGIT S INT=0
  1.  F  Q:HEX=""  D
  1.  . S INT=INT*16
  1.  . S DIGIT=$F(HEXTBL,$E(HEX,1,1))-2
  1.  . S INT=INT+DIGIT,HEX=$E(HEX,2,9999)
  1.  Q INT
  1. CRCTABLE(IDX) ; Returns crc hex value from table
  1.  N VALUE,LINE,OFFSET
  1.  I (IDX<0)!(IDX>255) Q 0
  1.  S LINE=(IDX/8)+1
  1.  S LINE=$T(TBL+LINE)
  1.  S OFFSET=IDX#8
  1.  S IDX=(OFFSET*10)+4
  1.  S VALUE=$E(LINE,IDX,IDX+7)
  1.  Q $TR(VALUE," ")
  1. TBL ; CRC table - DO NOT CHANGE THESE VALUES!
  1.  ;;0         77073096  EE0E612C  990951BA  76DC419   706AF48F  E963A535  9E6495A3 
  1.  ;;EDB8832   79DCB8A4  E0D5E91E  97D2D988  9B64C2B   7EB17CBD  E7B82D07  90BF1D91 
  1.  ;;1DB71064  6AB020F2  F3B97148  84BE41DE  1ADAD47D  6DDDE4EB  F4D4B551  83D385C7 
  1.  ;;136C9856  646BA8C0  FD62F97A  8A65C9EC  14015C4F  63066CD9  FA0F3D63  8D080DF5 
  1.  ;;3B6E20C8  4C69105E  D56041E4  A2677172  3C03E4D1  4B04D447  D20D85FD  A50AB56B 
  1.  ;;35B5A8FA  42B2986C  DBBBC9D6  ACBCF940  32D86CE3  45DF5C75  DCD60DCF  ABD13D59 
  1.  ;;26D930AC  51DE003A  C8D75180  BFD06116  21B4F4B5  56B3C423  CFBA9599  B8BDA50F 
  1.  ;;2802B89E  5F058808  C60CD9B2  B10BE924  2F6F7C87  58684C11  C1611DAB  B6662D3D 
  1.  ;;76DC4190  1DB7106   98D220BC  EFD5102A  71B18589  6B6B51F   9FBFE4A5  E8B8D433 
  1.  ;;7807C9A2  F00F934   9609A88E  E10E9818  7F6A0DBB  86D3D2D   91646C97  E6635C01 
  1.  ;;6B6B51F4  1C6C6162  856530D8  F262004E  6C0695ED  1B01A57B  8208F4C1  F50FC457 
  1.  ;;65B0D9C6  12B7E950  8BBEB8EA  FCB9887C  62DD1DDF  15DA2D49  8CD37CF3  FBD44C65 
  1.  ;;4DB26158  3AB551CE  A3BC0074  D4BB30E2  4ADFA541  3DD895D7  A4D1C46D  D3D6F4FB 
  1.  ;;4369E96A  346ED9FC  AD678846  DA60B8D0  44042D73  33031DE5  AA0A4C5F  DD0D7CC9 
  1.  ;;5005713C  270241AA  BE0B1010  C90C2086  5768B525  206F85B3  B966D409  CE61E49F 
  1.  ;;5EDEF90E  29D9C998  B0D09822  C7D7A8B4  59B33D17  2EB40D81  B7BD5C3B  C0BA6CAD 
  1.  ;;EDB88320  9ABFB3B6  3B6E20C   74B1D29A  EAD54739  9DD277AF  4DB2615   73DC1683 
  1.  ;;E3630B12  94643B84  D6D6A3E   7A6A5AA8  E40ECF0B  9309FF9D  A00AE27   7D079EB1 
  1.  ;;F00F9344  8708A3D2  1E01F268  6906C2FE  F762575D  806567CB  196C3671  6E6B06E7 
  1.  ;;FED41B76  89D32BE0  10DA7A5A  67DD4ACC  F9B9DF6F  8EBEEFF9  17B7BE43  60B08ED5 
  1.  ;;D6D6A3E8  A1D1937E  38D8C2C4  4FDFF252  D1BB67F1  A6BC5767  3FB506DD  48B2364B 
  1.  ;;D80D2BDA  AF0A1B4C  36034AF6  41047A60  DF60EFC3  A867DF55  316E8EEF  4669BE79 
  1.  ;;CB61B38C  BC66831A  256FD2A0  5268E236  CC0C7795  BB0B4703  220216B9  5505262F 
  1.  ;;C5BA3BBE  B2BD0B28  2BB45A92  5CB36A04  C2D7FFA7  B5D0CF31  2CD99E8B  5BDEAE1D 
  1.  ;;9B64C2B0  EC63F226  756AA39C  26D930A   9C0906A9  EB0E363F  72076785  5005713 
  1.  ;;95BF4A82  E2B87A14  7BB12BAE  CB61B38   92D28E9B  E5D5BE0D  7CDCEFB7  BDBDF21 
  1.  ;;86D3D2D4  F1D4E242  68DDB3F8  1FDA836E  81BE16CD  F6B9265B  6FB077E1  18B74777 
  1.  ;;88085AE6  FF0F6A70  66063BCA  11010B5C  8F659EFF  F862AE69  616BFFD3  166CCF45 
  1.  ;;A00AE278  D70DD2EE  4E048354  3903B3C2  A7672661  D06016F7  4969474D  3E6E77DB 
  1.  ;;AED16A4A  D9D65ADC  40DF0B66  37D83BF0  A9BCAE53  DEBB9EC5  47B2CF7F  30B5FFE9 
  1.  ;;BDBDF21C  CABAC28A  53B39330  24B4A3A6  BAD03605  CDD70693  54DE5729  23D967BF 
  1.  ;;B3667A2E  C4614AB8  5D681B02  2A6F2B94  B40BBE37  C30C8EA1  5A05DF1B  2D02EF8D