- 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
