source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LAFUNC.m@ 1336

LAFUNC ;SLC/DLG - GENERIC FUNCTIONS USED BY LA ROUTINES ;7/20/90  08:28 ;
 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
 ;CHECKSUM CALCULATIONS AND NUMBER BASE CONVERSIONS.
 ;CHECKSUM CALCULATION VARIABLES
 ;  LAX = STRING FOR CALCULATION
 ;  LAS = POSITION TO START CALCULATION
 ;  LAE = POSITION TO STOP CALCULATION
 ;  LAY = FULL NUMERIC VALUE OF CHECKSUM
 ;NUMBER BASE CONVERSION VARIABLES
 ;  LAX = NUMBER TO CONVERT
 ;  LAY = NUMBER IN NEW BASE
 ;  LAS, LAE = NOT USED
 ;ALL INTERNAL VARIABLES KILED.  LAX,LAS,LAE RETURNED UNCHANGED
 ;
AND ;AND AL CHAR IN STRING
 S LAY=$A(LAX,LAS) F II=LAS+1:1:LAE S LAY=LAY+$A(LAX,II)
 Q:$D(F)  G EXIT
NAND ;NOT AND OF STRING OF CHAR
 S F=0 D AND S LAY=-(LAY+1) G EXIT
OR ;OR AL CHAR IN STRING
 S LAY=$A(LAX,LAS) F II=LAS+1:1:LAE S M=LAY,N=$A(LAX,II),B=64,LAY=0 X "F JJ=1:1:7 S K=M\B,L=N\B,O=$S(((K=L)&(M=0)):0,1:1),LAY=LAY*2+O,M=M#B,N=N#B,B=B\2"
 Q:$D(F)  G EXIT
NOR ;NOT OR OF STRING
 S F=0 D OR S LAY=-(LAY+1) G EXIT
XOR ;XOR AL CHAR IN STRING
 S LAY=$A(LAX,LAS) F II=LAS+1:1:LAE S M=LAY,N=$A(LAX,II),B=64,LAY=0 X "F JJ=1:1:7 S K=M\B,L=N\B,O=$S(K=L:0,1:1),LAY=LAY*2+O,M=M#B,N=N#B,B=B\2"
 Q:$D(F)  G EXIT
XNOR ;EXCLUSIVE NOT OR OF STRING
 S F=0 D XOR S LAY=-(LAY+1) G EXIT
BTOO ;BINARY STRING TO OCTAL
 S TEMP=LAX,F=0 D BTOD S LAX=LAY D DTOO S LAX=TEMP G EXIT
BTOD ;BINARY STRING TO DECIMAL
 S LAY=0 F II=1:1:$L(LAX) S LAY=LAY*2+$E(LAX,II)
 Q:$D(F)  G EXIT
BTOH ;BINARY STRING TO HEX
 S TEMP=LAX,F=0 D BTOD S LAX=LAY D DTOH S LAX=TEMP G EXIT
OTOB ;OCTAL TO BINARY STRING
 S TEMP=LAX,F=0 D OTOD S LAX=LAY D DTOB S LAX=TEMP G EXIT
OTOD ;OCTAL TO DECIMAL
 S K=LAX,LAY=0 F II=1:1:$L(K) S LAY=LAY*8+$F("01234567",$E(K,II))-2
 Q:$D(F)  G EXIT
OTOH ;OCTAL TO HEX
 S TEMP=LAX,F=0 D OTOD S LAX=LAY D DTOH S LAX=TEMP G EXIT
DTOB ;DECIMAL VALUE TO BINARY STRING
 S K=LAX,LAY="" F II=0:0 S L=K#2,K=K\2,LAY=L_LAY Q:K=0
 Q:$D(F)  G EXIT
DTOO ;DECIMAL TO OCTAL
 S K=LAX,LAY="",B=8,M=1
 F II=0:0 S L=K#B\M,LAY=$E("01234567",(L+1))_LAY,M=M*8,B=B*8 Q:(K\M=0)
 Q:$D(F)  G EXIT
DTOH ;CHANGE DECIMAL VALUE TO 6 HEX CHARACTERS
 S M=1,B=16,K=LAX,LAY=""
 F II=0:0 S L=K#B\M S LAY=$E("0123456789ABCDEF",(L+1))_LAY,M=M*16,B=B*16 Q:(K\M=0)
 Q:$D(F)  G EXIT
HTOB ;HEX VALUE TO BINARY STRING
 S TEMP=LAX,F=0 D HTOD S LAX=LAY D DTOB S LAX=TEMP G EXIT
HTOO ;HEX TO OCTAL
 S TEMP=LAX,F=0 D HTOD S LAX=LAY D DTOO S LAX=TEMP G EXIT
HTOD ;CHANGE HEX TO DECIMAL VALUE
 S K=LAX,LAY=0 F II=1:1:$L(K) S LAY=LAY*16+$F("0123456789ABCDEF",$E(K,II))-2
 Q:$D(F)  G EXIT
NUM W !,"ENTER NUMBER WITH BASE AS LAST CHAR. IE 0101B FOR BINARY: "
 R LAX:DTIME G EXIT0:'$T,EXIT0:LAX="",EXIT0:LAX="^",NUM1:"BODH"[$E(LAX,$L(LAX))
 W !!,"ENTER THE NUMBER FOLLOWED BY STARTING BASE. IE 3FH FOR 3F HEX." H 5 G NUM
NUM1 S STR=$E(LAX,$L(LAX))_"TO",LAX=$E(LAX,1,($L(LAX)-1)),F=1,TY=0 F I=1:1:$L(LAX) S:TY<$A(LAX,I) TY=$A(LAX,I)
 I STR="BTO",TY<50 S CAL=STR_"O" D @CAL S LAY(2)=LAY,CAL=STR_"D" D @CAL S LAY(3)=LAY S CAL=STR_"H" D @CAL S LAY(4)=LAY,LAY(1)=LAX G PRT
 I STR="OTO",TY<56 S CAL=STR_"B" D @CAL S LAY(1)=LAY,CAL=STR_"D" D @CAL S LAY(3)=LAY S CAL=STR_"H" D @CAL S LAY(4)=LAY,LAY(2)=LAX G PRT
 I STR="DTO",LAX?.N S CAL=STR_"B" D @CAL S LAY(1)=LAY,CAL=STR_"O" D @CAL S LAY(2)=LAY S CAL=STR_"H" D @CAL S LAY(4)=LAY,LAY(3)=LAX G PRT
 I STR="HTO",((TY<58)!((TY>64)&(TY<71))) S CAL=STR_"B" D @CAL S LAY(1)=LAY,CAL=STR_"O" D @CAL S LAY(2)=LAY S CAL=STR_"D" D @CAL S LAY(3)=LAY,LAY(4)=LAX G PRT
 W !,"INVALID NUMBER",! H 5 G NUM
PRT W !," BINARY: ",LAY(1),!,"  OCTAL: ",LAY(2),!,"DECIMAL: ",LAY(3),!,"    HEX: ",LAY(4),! K LAY G NUM
TABLE ;PRINT TABLE OF CONVERSIONS FOR 0 TO 256 DECIMAL
 D ^%ZIS Q:POP  S PAGE=0 U IO D HDR
 F I=0:1:256 S LAX=I D DTOB W $J(LAY,9) D DTOO W ?11,$J(LAY,3) W ?16,$J(I,3) S LAX=I D DTOH W ?21,$J(LAY,3) W:((I>31)&(I<128)) ?27,$C(I) W ! D:(($Y+4)>IOSL) HDR
 W @IOF U IO(0) D:IO'=IO(0) ^%ZISC G EXIT
HDR S PAGE=PAGE+1 W @IOF,"NUMBER BASE CONVERSION TABLE",?(IOM-10),"PAGE: ",$J(PAGE,2),!,"  BINARY   OCT  DEC  HEX  ASC",!
 F J=1:1:(IOM-2) W "-"
 W !! Q
EXIT0 K CAL,STR,TY
EXIT K B,F,II,JJ,K,L,M,N,O,TEMP Q