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