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