source: FOIAVistA/tag/r/CLINICAL_CASE_REGISTRIES-ROR/RORBIN.m@ 628

RORBIN ;HCIOFO/SG - BINARY OPERATIONS  ; 1/23/06 1:54pm
 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
 ;
 Q
 ;
 ;***** BINARY "AND" OPERATION
 ;
 ; V1            Operands formatted as strings of "1" and "0"
 ; V2
 ;
AND(V1,V2) ;
 N I,L1,L2,N,RES
 S L1=$L(V1),L2=$L(V2),RES=""
 I L1<L2  S N=L1,V2=$E(V2,L2-L1+1,L2)
 E        S N=L2,V1=$E(V1,L1-L2+1,L1)
 F I=1:1:N  S RES=RES_$S($E(V1,I)&$E(V2,I):"1",1:"0")
 Q RES
 ;
 ;***** FAST CONVERSIONS FROM HEXADECIMAL TO BINARY
 ;
 ; VAL           Hexadecimal value
 ;
C16TO2(VAL) ;
 N I,J,L,RES
 S L=$L(VAL),RES=""
 F I=1:1:L  D
 . S J=$F("0123456789ABCDEF",$E(VAL,I))-1
 . S RES=RES_$P("0000^0001^0010^0011^0100^0101^0110^0111^1000^1001^1010^1011^1100^1101^1110^1111","^",J)
 Q RES
 ;
 ;***** CALCULATES CRC-32 FOR PROVIDED DATA
 ;
 ; ROR8NODE      Closed root of an array that contains the data
 ;
CRC32(ROR8NODE) ;
 N TMPCRC  S TMPCRC=$$C16TO2("FFFFFFFF")
 F  S ROR8NODE=$Q(@ROR8NODE)  Q:ROR8NODE=""  D
 . S TMPCRC=$$UPDCRC32(TMPCRC,@ROR8NODE)
 S TMPCRC=$$BASE^XLFUTL($$NOT(TMPCRC),2,16)
 Q $TR($J(TMPCRC,8)," ","0")
 ;
 ;***** BINARY "NOT" OPERATION
 ;
 ; V1            Operand formatted as string of "1" and "0"
 ;
NOT(VAL) ;
 Q $TR(VAL,"01","10")
 ;
 ;***** BINARY "OR" OPERATION
 ;
 ; V1            Operands formatted as strings of "1" and "0"
 ; V2
 ;
OR(V1,V2) ;
 N I,L1,L2,N,RES,TMP
 S L1=$L(V1),L2=$L(V2)
 I L1<L2  S N=L1,RES=$E(V2,1,L2-L1),V2=$E(V2,L2-L1+1,L2)
 E        S N=L2,RES=$E(V1,1,L1-L2),V1=$E(V1,L1-L2+1,L1)
 F I=1:1:N  S RES=RES_$S($E(V1,I)!$E(V2,I):"1",1:"0")
 Q RES
 ;
 ;***** RIGHT SHIFT (SIGNED OF UNSIGNED)
 ;
 ; V1            Operands formatted as strings of "1" and "0"
 ; V2
 ;
 ; N             Number of bits to shift by
 ;
 ; SIGN          If this parameter defined and greater than 0, then
 ;               "signed" shift is performed (sign bit is propagated).
 ;               Parameter value defines the maximum number of bits
 ;               allowed for the values.
 ;
 ;               By default ($G(SIGN)'>0), "unsigned" shift is
 ;               performed.
 ;
SHR(VAL,N,SIGN) ;
 N FILL,L,RES,SIZE
 S L=$L(VAL)
 Q:$G(SIGN)'>0 $S(N<L:$E(VAL,1,L-N),1:"0")
 S SIZE=+SIGN
 ;---
 S:L>SIZE VAL=$E(VAL,L-SIZE+1,L),L=SIZE
 S SIGN=$S(L<SIZE:0,1:$E(VAL,1))
 S:N>SIZE N=SIZE
 S:SIGN $P(FILL,"1",N+1)=""
 Q $E($G(FILL)_$S(N<L:$E(VAL,1,L-N),1:"0"),1,SIZE)
 ;
 ;***** INTERNAL ENTRY POINT FOR CRC-32 CALCULATION
UPDCRC32(CRC32,STR) ;
 N FFFFFF,I,I32,L
 S L=$L(STR),FFFFFF=$$C16TO2("FFFFFF")
 F I=1:1:L  D
 . S I32=$$XOR(CRC32,$$CNV^XLFUTL($A(STR,I),2))
 . S I32=$$DEC^XLFUTL(I32,2)#256+1
 . S TMP=$$C16TO2($P($T(TBL+I32),";;",2))
 . S CRC32=$$XOR($$AND($$SHR(CRC32,8,32),FFFFFF),TMP)
 Q CRC32
 ;
 ;***** BINARY "EXCLUSIVE OR" OPERATION
 ;
 ; V1            Operands formatted as strings of "1" and "0"
 ; V2
 ;
XOR(V1,V2) ;
 N I,L1,L2,N,RES,TMP
 S L1=$L(V1),L2=$L(V2)
 I L1<L2  S N=L1,RES=$E(V2,1,L2-L1),V2=$E(V2,L2-L1+1,L2)
 E        S N=L2,RES=$E(V1,1,L1-L2),V1=$E(V1,L1-L2+1,L1)
 F I=1:1:N  S RES=RES_$S($E(V1,I)+$E(V2,I)=1:"1",1:"0")
 Q RES
 ;
 ;***** TABLE FOR CRC-32 CALCULATION
TBL ;
 ;;00000000
 ;;77073096
 ;;EE0E612C
 ;;990951BA
 ;;076DC419
 ;;706AF48F
 ;;E963A535
 ;;9E6495A3
 ;;0EDB8832
 ;;79DCB8A4
 ;;E0D5E91E
 ;;97D2D988
 ;;09B64C2B
 ;;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
 ;;01DB7106
 ;;98D220BC
 ;;EFD5102A
 ;;71B18589
 ;;06B6B51F
 ;;9FBFE4A5
 ;;E8B8D433
 ;;7807C9A2
 ;;0F00F934
 ;;9609A88E
 ;;E10E9818
 ;;7F6A0DBB
 ;;086D3D2D
 ;;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
 ;;03B6E20C
 ;;74B1D29A
 ;;EAD54739
 ;;9DD277AF
 ;;04DB2615
 ;;73DC1683
 ;;E3630B12
 ;;94643B84
 ;;0D6D6A3E
 ;;7A6A5AA8
 ;;E40ECF0B
 ;;9309FF9D
 ;;0A00AE27
 ;;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
 ;;026D930A
 ;;9C0906A9
 ;;EB0E363F
 ;;72076785
 ;;05005713
 ;;95BF4A82
 ;;E2B87A14
 ;;7BB12BAE
 ;;0CB61B38
 ;;92D28E9B
 ;;E5D5BE0D
 ;;7CDCEFB7
 ;;0BDBDF21
 ;;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