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

RORBIN.m

Go to the documentation of this file. 
  1. RORBIN ;HCIOFO/SG - BINARY OPERATIONS  ; 1/23/06 1:54pm
  1.  ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
  1.  ;
  1.  Q
  1.  ;
  1.  ;***** BINARY "AND" OPERATION
  1.  ;
  1.  ; V1            Operands formatted as strings of "1" and "0"
  1.  ; V2
  1.  ;
  1. AND(V1,V2) ;
  1.  N I,L1,L2,N,RES
  1.  S L1=$L(V1),L2=$L(V2),RES=""
  1.  I L1<L2  S N=L1,V2=$E(V2,L2-L1+1,L2)
  1.  E        S N=L2,V1=$E(V1,L1-L2+1,L1)
  1.  F I=1:1:N  S RES=RES_$S($E(V1,I)&$E(V2,I):"1",1:"0")
  1.  Q RES
  1.  ;
  1.  ;***** FAST CONVERSIONS FROM HEXADECIMAL TO BINARY
  1.  ;
  1.  ; VAL           Hexadecimal value
  1.  ;
  1. C16TO2(VAL) ;
  1.  N I,J,L,RES
  1.  S L=$L(VAL),RES=""
  1.  F I=1:1:L  D
  1.  . S J=$F("0123456789ABCDEF",$E(VAL,I))-1
  1.  . S RES=RES_$P("0000^0001^0010^0011^0100^0101^0110^0111^1000^1001^1010^1011^1100^1101^1110^1111","^",J)
  1.  Q RES
  1.  ;
  1.  ;***** CALCULATES CRC-32 FOR PROVIDED DATA
  1.  ;
  1.  ; ROR8NODE      Closed root of an array that contains the data
  1.  ;
  1. CRC32(ROR8NODE) ;
  1.  N TMPCRC  S TMPCRC=$$C16TO2("FFFFFFFF")
  1.  F  S ROR8NODE=$Q(@ROR8NODE)  Q:ROR8NODE=""  D
  1.  . S TMPCRC=$$UPDCRC32(TMPCRC,@ROR8NODE)
  1.  S TMPCRC=$$BASE^XLFUTL($$NOT(TMPCRC),2,16)
  1.  Q $TR($J(TMPCRC,8)," ","0")
  1.  ;
  1.  ;***** BINARY "NOT" OPERATION
  1.  ;
  1.  ; V1            Operand formatted as string of "1" and "0"
  1.  ;
  1. NOT(VAL) ;
  1.  Q $TR(VAL,"01","10")
  1.  ;
  1.  ;***** BINARY "OR" OPERATION
  1.  ;
  1.  ; V1            Operands formatted as strings of "1" and "0"
  1.  ; V2
  1.  ;
  1. OR(V1,V2) ;
  1.  N I,L1,L2,N,RES,TMP
  1.  S L1=$L(V1),L2=$L(V2)
  1.  I L1<L2  S N=L1,RES=$E(V2,1,L2-L1),V2=$E(V2,L2-L1+1,L2)
  1.  E        S N=L2,RES=$E(V1,1,L1-L2),V1=$E(V1,L1-L2+1,L1)
  1.  F I=1:1:N  S RES=RES_$S($E(V1,I)!$E(V2,I):"1",1:"0")
  1.  Q RES
  1.  ;
  1.  ;***** RIGHT SHIFT (SIGNED OF UNSIGNED)
  1.  ;
  1.  ; V1            Operands formatted as strings of "1" and "0"
  1.  ; V2
  1.  ;
  1.  ; N             Number of bits to shift by
  1.  ;
  1.  ; SIGN          If this parameter defined and greater than 0, then
  1.  ;               "signed" shift is performed (sign bit is propagated).
  1.  ;               Parameter value defines the maximum number of bits
  1.  ;               allowed for the values.
  1.  ;
  1.  ;               By default ($G(SIGN)'>0), "unsigned" shift is
  1.  ;               performed.
  1.  ;
  1. SHR(VAL,N,SIGN) ;
  1.  N FILL,L,RES,SIZE
  1.  S L=$L(VAL)
  1.  Q:$G(SIGN)'>0 $S(N<L:$E(VAL,1,L-N),1:"0")
  1.  S SIZE=+SIGN
  1.  ;---
  1.  S:L>SIZE VAL=$E(VAL,L-SIZE+1,L),L=SIZE
  1.  S SIGN=$S(L<SIZE:0,1:$E(VAL,1))
  1.  S:N>SIZE N=SIZE
  1.  S:SIGN $P(FILL,"1",N+1)=""
  1.  Q $E($G(FILL)_$S(N<L:$E(VAL,1,L-N),1:"0"),1,SIZE)
  1.  ;
  1.  ;***** INTERNAL ENTRY POINT FOR CRC-32 CALCULATION
  1. UPDCRC32(CRC32,STR) ;
  1.  N FFFFFF,I,I32,L
  1.  S L=$L(STR),FFFFFF=$$C16TO2("FFFFFF")
  1.  F I=1:1:L  D
  1.  . S I32=$$XOR(CRC32,$$CNV^XLFUTL($A(STR,I),2))
  1.  . S I32=$$DEC^XLFUTL(I32,2)#256+1
  1.  . S TMP=$$C16TO2($P($T(TBL+I32),";;",2))
  1.  . S CRC32=$$XOR($$AND($$SHR(CRC32,8,32),FFFFFF),TMP)
  1.  Q CRC32
  1.  ;
  1.  ;***** BINARY "EXCLUSIVE OR" OPERATION
  1.  ;
  1.  ; V1            Operands formatted as strings of "1" and "0"
  1.  ; V2
  1.  ;
  1. XOR(V1,V2) ;
  1.  N I,L1,L2,N,RES,TMP
  1.  S L1=$L(V1),L2=$L(V2)
  1.  I L1<L2  S N=L1,RES=$E(V2,1,L2-L1),V2=$E(V2,L2-L1+1,L2)
  1.  E        S N=L2,RES=$E(V1,1,L1-L2),V1=$E(V1,L1-L2+1,L1)
  1.  F I=1:1:N  S RES=RES_$S($E(V1,I)+$E(V2,I)=1:"1",1:"0")
  1.  Q RES
  1.  ;
  1.  ;***** TABLE FOR CRC-32 CALCULATION
  1. TBL ;
  1.  ;;00000000
  1.  ;;77073096
  1.  ;;EE0E612C
  1.  ;;990951BA
  1.  ;;076DC419
  1.  ;;706AF48F
  1.  ;;E963A535
  1.  ;;9E6495A3
  1.  ;;0EDB8832
  1.  ;;79DCB8A4
  1.  ;;E0D5E91E
  1.  ;;97D2D988
  1.  ;;09B64C2B
  1.  ;;7EB17CBD
  1.  ;;E7B82D07
  1.  ;;90BF1D91
  1.  ;;1DB71064
  1.  ;;6AB020F2
  1.  ;;F3B97148
  1.  ;;84BE41DE
  1.  ;;1ADAD47D
  1.  ;;6DDDE4EB
  1.  ;;F4D4B551
  1.  ;;83D385C7
  1.  ;;136C9856
  1.  ;;646BA8C0
  1.  ;;FD62F97A
  1.  ;;8A65C9EC
  1.  ;;14015C4F
  1.  ;;63066CD9
  1.  ;;FA0F3D63
  1.  ;;8D080DF5
  1.  ;;3B6E20C8
  1.  ;;4C69105E
  1.  ;;D56041E4
  1.  ;;A2677172
  1.  ;;3C03E4D1
  1.  ;;4B04D447
  1.  ;;D20D85FD
  1.  ;;A50AB56B
  1.  ;;35B5A8FA
  1.  ;;42B2986C
  1.  ;;DBBBC9D6
  1.  ;;ACBCF940
  1.  ;;32D86CE3
  1.  ;;45DF5C75
  1.  ;;DCD60DCF
  1.  ;;ABD13D59
  1.  ;;26D930AC
  1.  ;;51DE003A
  1.  ;;C8D75180
  1.  ;;BFD06116
  1.  ;;21B4F4B5
  1.  ;;56B3C423
  1.  ;;CFBA9599
  1.  ;;B8BDA50F
  1.  ;;2802B89E
  1.  ;;5F058808
  1.  ;;C60CD9B2
  1.  ;;B10BE924
  1.  ;;2F6F7C87
  1.  ;;58684C11
  1.  ;;C1611DAB
  1.  ;;B6662D3D
  1.  ;;76DC4190
  1.  ;;01DB7106
  1.  ;;98D220BC
  1.  ;;EFD5102A
  1.  ;;71B18589
  1.  ;;06B6B51F
  1.  ;;9FBFE4A5
  1.  ;;E8B8D433
  1.  ;;7807C9A2
  1.  ;;0F00F934
  1.  ;;9609A88E
  1.  ;;E10E9818
  1.  ;;7F6A0DBB
  1.  ;;086D3D2D
  1.  ;;91646C97
  1.  ;;E6635C01
  1.  ;;6B6B51F4
  1.  ;;1C6C6162
  1.  ;;856530D8
  1.  ;;F262004E
  1.  ;;6C0695ED
  1.  ;;1B01A57B
  1.  ;;8208F4C1
  1.  ;;F50FC457
  1.  ;;65B0D9C6
  1.  ;;12B7E950
  1.  ;;8BBEB8EA
  1.  ;;FCB9887C
  1.  ;;62DD1DDF
  1.  ;;15DA2D49
  1.  ;;8CD37CF3
  1.  ;;FBD44C65
  1.  ;;4DB26158
  1.  ;;3AB551CE
  1.  ;;A3BC0074
  1.  ;;D4BB30E2
  1.  ;;4ADFA541
  1.  ;;3DD895D7
  1.  ;;A4D1C46D
  1.  ;;D3D6F4FB
  1.  ;;4369E96A
  1.  ;;346ED9FC
  1.  ;;AD678846
  1.  ;;DA60B8D0
  1.  ;;44042D73
  1.  ;;33031DE5
  1.  ;;AA0A4C5F
  1.  ;;DD0D7CC9
  1.  ;;5005713C
  1.  ;;270241AA
  1.  ;;BE0B1010
  1.  ;;C90C2086
  1.  ;;5768B525
  1.  ;;206F85B3
  1.  ;;B966D409
  1.  ;;CE61E49F
  1.  ;;5EDEF90E
  1.  ;;29D9C998
  1.  ;;B0D09822
  1.  ;;C7D7A8B4
  1.  ;;59B33D17
  1.  ;;2EB40D81
  1.  ;;B7BD5C3B
  1.  ;;C0BA6CAD
  1.  ;;EDB88320
  1.  ;;9ABFB3B6
  1.  ;;03B6E20C
  1.  ;;74B1D29A
  1.  ;;EAD54739
  1.  ;;9DD277AF
  1.  ;;04DB2615
  1.  ;;73DC1683
  1.  ;;E3630B12
  1.  ;;94643B84
  1.  ;;0D6D6A3E
  1.  ;;7A6A5AA8
  1.  ;;E40ECF0B
  1.  ;;9309FF9D
  1.  ;;0A00AE27
  1.  ;;7D079EB1
  1.  ;;F00F9344
  1.  ;;8708A3D2
  1.  ;;1E01F268
  1.  ;;6906C2FE
  1.  ;;F762575D
  1.  ;;806567CB
  1.  ;;196C3671
  1.  ;;6E6B06E7
  1.  ;;FED41B76
  1.  ;;89D32BE0
  1.  ;;10DA7A5A
  1.  ;;67DD4ACC
  1.  ;;F9B9DF6F
  1.  ;;8EBEEFF9
  1.  ;;17B7BE43
  1.  ;;60B08ED5
  1.  ;;D6D6A3E8
  1.  ;;A1D1937E
  1.  ;;38D8C2C4
  1.  ;;4FDFF252
  1.  ;;D1BB67F1
  1.  ;;A6BC5767
  1.  ;;3FB506DD
  1.  ;;48B2364B
  1.  ;;D80D2BDA
  1.  ;;AF0A1B4C
  1.  ;;36034AF6
  1.  ;;41047A60
  1.  ;;DF60EFC3
  1.  ;;A867DF55
  1.  ;;316E8EEF
  1.  ;;4669BE79
  1.  ;;CB61B38C
  1.  ;;BC66831A
  1.  ;;256FD2A0
  1.  ;;5268E236
  1.  ;;CC0C7795
  1.  ;;BB0B4703
  1.  ;;220216B9
  1.  ;;5505262F
  1.  ;;C5BA3BBE
  1.  ;;B2BD0B28
  1.  ;;2BB45A92
  1.  ;;5CB36A04
  1.  ;;C2D7FFA7
  1.  ;;B5D0CF31
  1.  ;;2CD99E8B
  1.  ;;5BDEAE1D
  1.  ;;9B64C2B0
  1.  ;;EC63F226
  1.  ;;756AA39C
  1.  ;;026D930A
  1.  ;;9C0906A9
  1.  ;;EB0E363F
  1.  ;;72076785
  1.  ;;05005713
  1.  ;;95BF4A82
  1.  ;;E2B87A14
  1.  ;;7BB12BAE
  1.  ;;0CB61B38
  1.  ;;92D28E9B
  1.  ;;E5D5BE0D
  1.  ;;7CDCEFB7
  1.  ;;0BDBDF21
  1.  ;;86D3D2D4
  1.  ;;F1D4E242
  1.  ;;68DDB3F8
  1.  ;;1FDA836E
  1.  ;;81BE16CD
  1.  ;;F6B9265B
  1.  ;;6FB077E1
  1.  ;;18B74777
  1.  ;;88085AE6
  1.  ;;FF0F6A70
  1.  ;;66063BCA
  1.  ;;11010B5C
  1.  ;;8F659EFF
  1.  ;;F862AE69
  1.  ;;616BFFD3
  1.  ;;166CCF45
  1.  ;;A00AE278
  1.  ;;D70DD2EE
  1.  ;;4E048354
  1.  ;;3903B3C2
  1.  ;;A7672661
  1.  ;;D06016F7
  1.  ;;4969474D
  1.  ;;3E6E77DB
  1.  ;;AED16A4A
  1.  ;;D9D65ADC
  1.  ;;40DF0B66
  1.  ;;37D83BF0
  1.  ;;A9BCAE53
  1.  ;;DEBB9EC5
  1.  ;;47B2CF7F
  1.  ;;30B5FFE9
  1.  ;;BDBDF21C
  1.  ;;CABAC28A
  1.  ;;53B39330
  1.  ;;24B4A3A6
  1.  ;;BAD03605
  1.  ;;CDD70693
  1.  ;;54DE5729
  1.  ;;23D967BF
  1.  ;;B3667A2E
  1.  ;;C4614AB8
  1.  ;;5D681B02
  1.  ;;2A6F2B94
  1.  ;;B40BBE37
  1.  ;;C30C8EA1
  1.  ;;5A05DF1B
  1.  ;;2D02EF8D