source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCRC.m@ 1446

Last change on this file since 1446 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 6.0 KB
Line 
1ORCRC ;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 ;
16CRC4ARRY(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 ;
40XOR(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
50AND(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
58SHR(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
62HEX2BIN(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
69BIN2HEX(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
78INT2HEX(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
86HEX2INT(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
93CRCTABLE(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," ")
102TBL ; 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
Note: See TracBrowser for help on using the repository browser.