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