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